#ifdef DEBUG
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
+#define CHK_Ubiq() import Ubiq
#else
#define ASSERT(e)
+#define CHK_Ubiq()
#endif
-- ToDo: ghci needs to load far too many bits of the backend because
#endif
SUBDIRS = __ghc_compiler_tests_dir
#undef __ghc_compiler_tests_dir
-/* ?????? ToDo: something about test dirs underneath yaccParser ????? */
-
-#if BuildDataParallelHaskell != YES
- /* DPH likes to play around in subdirs */
-# define NoAllTargetForSubdirs
-# define NoDocsTargetForSubdirs
-# define NoInstallDocsTargetForSubdirs
-# define NoDependTargetForSubdirs
-#endif
- /* these always apply */
-# define NoInstallTargetForSubdirs
+
+#define NoAllTargetForSubdirs
+#define NoDocsTargetForSubdirs
+#define NoInstallDocsTargetForSubdirs
+#define NoDependTargetForSubdirs
+#define NoInstallTargetForSubdirs
#define NoTagTargetForSubdirs
/* Suffix rules: we do not use them much at all in GHC.
*/
SUBDIR_LIST = \ /* here they are, colon separated (for mkdependHS) */
-utils:basicTypes:uniType:abstractSyn:prelude:envs:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:podizeCore:yaccParser:nhcParser:interpreter
-
-DASH_I_SUBDIR_LIST = \ /* same thing, in -I<dir> format */
--Iutils -IbasicTypes -IuniType -IabstractSyn -Iprelude -Ienvs -Irename -Itypecheck -IdeSugar -IcoreSyn -Ispecialise -IsimplCore -Istranal -IstgSyn -IsimplStg -IcodeGen -InativeGen -IabsCSyn -Imain -Ireader -Iprofiling -Ideforest -IpodizeCore -IyaccParser -InhcParser -Iinterpreter
+utils:basicTypes:types:hsSyn:prelude:envs:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:parser
#ifdef MainIncludeDir
MAIN_INCLUDE_DIR=MainIncludeDir
/* in order-of-passes order, utility modules at the end */
-#if GhcBuilderVersion >= 23 && GhcBuildeeVersion >= 23
-# define USE_NEW_READER YES
-# define __new_reader_flag -DUSE_NEW_READER=1
-#else
-# define __new_reader_flag /*none*/
-#endif
-#if USE_NEW_READER == YES
-# define READERSRCS_HS \
-yaccParser/U_atype.hs \
-yaccParser/U_binding.hs \
-yaccParser/U_coresyn.hs \
-yaccParser/U_entidt.hs \
-yaccParser/U_finfot.hs \
-yaccParser/U_hpragma.hs \
-yaccParser/U_list.hs \
-yaccParser/U_literal.hs \
-yaccParser/U_pbinding.hs \
-yaccParser/U_treeHACK.hs \
-yaccParser/U_ttype.hs
-#define READERSRCS_LHS \
-yaccParser/UgenUtil.lhs \
-yaccParser/UgenAll.lhs \
-reader/ReadPrefix2.lhs \
-reader/ReadPragmas2.lhs
+#define READERSRCS_HS \
+parser/U_constr.hs \
+parser/U_binding.hs \
+parser/U_pbinding.hs \
+parser/U_coresyn.hs \
+parser/U_entidt.hs \
+parser/U_hpragma.hs \
+parser/U_list.hs \
+parser/U_literal.hs \
+parser/U_maybe.hs \
+parser/U_either.hs \
+parser/U_qid.hs \
+parser/U_tree.hs \
+parser/U_ttype.hs
+
#define hsp_library libhsp.a
-#else
-#define READERSRCS_HS /* none */
+
#define READERSRCS_LHS \
+parser/UgenUtil.lhs \
+parser/UgenAll.lhs \
reader/ReadPrefix.lhs \
-reader/ReadPragmas.lhs
-#define hsp_library /*none*/
-#endif
-
-#define FRONTSRCS_LHS \
+reader/ReadPragmas.lhs \
+\
reader/PrefixSyn.lhs \
reader/PrefixToHs.lhs \
+reader/RdrHsSyn.lhs \
\
-basicTypes/Unique.lhs \
-basicTypes/SplitUniq.lhs \
-basicTypes/ProtoName.lhs \
-basicTypes/NameTypes.lhs \
-basicTypes/SrcLoc.lhs \
-basicTypes/Id.lhs \
-basicTypes/IdInfo.lhs \
-basicTypes/Inst.lhs \
-basicTypes/BasicLit.lhs \
-basicTypes/CLabelInfo.lhs \
-basicTypes/OrdList.lhs \
-\
-uniType/TyVar.lhs \
-uniType/TyCon.lhs \
-uniType/Class.lhs \
-uniType/UniType.lhs \
-uniType/UniTyFuns.lhs \
-uniType/AbsUniType.lhs \
+hsSyn/HsBinds.lhs /* abstract Haskell syntax */ \
+hsSyn/HsCore.lhs \
+hsSyn/HsDecls.lhs \
+hsSyn/HsExpr.lhs \
+hsSyn/HsImpExp.lhs \
+hsSyn/HsLit.lhs \
+hsSyn/HsMatches.lhs \
+hsSyn/HsPat.lhs \
+hsSyn/HsPragmas.lhs \
+hsSyn/HsTypes.lhs \
+hsSyn/HsSyn.lhs
+
+#define NOT_SO_BASICSRCS_LHS \
+basicTypes/Unique.lhs \
+basicTypes/UniqSupply.lhs \
+basicTypes/ProtoName.lhs \
+basicTypes/Name.lhs \
+basicTypes/NameTypes.lhs \
+basicTypes/SrcLoc.lhs \
+basicTypes/Id.lhs \
+basicTypes/IdInfo.lhs \
+basicTypes/IdUtils.lhs \
+basicTypes/PragmaInfo.lhs \
+basicTypes/Literal.lhs \
\
-abstractSyn/Name.lhs /* abstract Haskell syntax */ \
-abstractSyn/HsCore.lhs \
-abstractSyn/HsPragmas.lhs \
-abstractSyn/HsImpExp.lhs \
-abstractSyn/HsDecls.lhs \
-abstractSyn/HsBinds.lhs \
-abstractSyn/HsMatches.lhs \
-abstractSyn/HsLit.lhs \
-abstractSyn/HsExpr.lhs \
-abstractSyn/HsPat.lhs \
-abstractSyn/HsTypes.lhs \
-abstractSyn/AbsSyn.lhs \
-abstractSyn/AbsSynFuns.lhs \
+types/Class.lhs \
+types/Kind.lhs \
+types/PprType.lhs \
+types/TyCon.lhs \
+types/TyVar.lhs \
+types/Usage.lhs \
+types/Type.lhs \
\
-rename/Rename.lhs \
-rename/Rename1.lhs \
-rename/Rename2.lhs \
-rename/Rename3.lhs \
-rename/Rename4.lhs \
-rename/RenameAuxFuns.lhs \
-rename/RenameMonad12.lhs \
-rename/RenameMonad3.lhs \
-rename/RenameMonad4.lhs \
-rename/RenameBinds4.lhs \
-rename/RenameExpr4.lhs
+specialise/SpecEnv.lhs
+
+
+#define RENAMERSRCS_LHS \
+rename/RnPass1.lhs \
+rename/RnPass2.lhs \
+rename/RnPass3.lhs \
+rename/RnPass4.lhs \
+rename/RnHsSyn.lhs \
+rename/RnUtils.lhs \
+rename/RnMonad12.lhs \
+rename/RnMonad3.lhs \
+rename/RnMonad4.lhs \
+rename/RnBinds4.lhs \
+rename/RnExpr4.lhs \
+rename/Rename.lhs
#define TCSRCS_LHS \
-prelude/PrelFuns.lhs \
-prelude/PrimKind.lhs \
-prelude/PrimOps.lhs \
-prelude/TysPrim.lhs \
-prelude/TysWiredIn.lhs \
-prelude/PrelVals.lhs \
-prelude/AbsPrel.lhs \
-\
-envs/IdEnv.lhs \
-envs/TyVarEnv.lhs \
-envs/LIE.lhs \
-envs/CE.lhs \
-envs/E.lhs \
-envs/InstEnv.lhs \
-envs/TCE.lhs \
-envs/TVE.lhs \
-\
-typecheck/BackSubst.lhs \
-typecheck/Disambig.lhs \
+typecheck/TcHsSyn.lhs \
typecheck/GenSpecEtc.lhs \
-typecheck/Spec.lhs \
-typecheck/Subst.lhs \
+typecheck/Inst.lhs \
typecheck/TcBinds.lhs \
typecheck/TcClassDcl.lhs \
-typecheck/TcClassSig.lhs \
-typecheck/TcConDecls.lhs \
-typecheck/TcContext.lhs \
typecheck/TcDefaults.lhs \
typecheck/TcDeriv.lhs \
typecheck/TcExpr.lhs \
-typecheck/TcGRHSs.lhs \
typecheck/TcGenDeriv.lhs \
+typecheck/TcGRHSs.lhs \
typecheck/TcIfaceSig.lhs \
typecheck/TcInstDcls.lhs \
+typecheck/TcInstUtil.lhs \
typecheck/TcMatches.lhs \
typecheck/TcModule.lhs \
typecheck/TcMonad.lhs \
-typecheck/TcMonadFns.lhs \
-typecheck/TcMonoBnds.lhs \
+typecheck/TcEnv.lhs \
+typecheck/TcKind.lhs \
+typecheck/TcType.lhs \
typecheck/TcMonoType.lhs \
typecheck/TcPat.lhs \
-typecheck/TcPolyType.lhs \
-typecheck/TcPragmas.lhs \
-typecheck/TcQuals.lhs \
typecheck/TcSimplify.lhs \
+typecheck/TcTyClsDecls.lhs \
typecheck/TcTyDecls.lhs \
typecheck/Typecheck.lhs \
typecheck/Unify.lhs
+/*
+typecheck/TcPragmas.lhs \
+*/
+
#define DSSRCS_LHS \
-coreSyn/AnnCoreSyn.lhs \
-coreSyn/CoreSyn.lhs \
-coreSyn/PlainCore.lhs \
-coreSyn/TaggedCore.lhs \
-coreSyn/CoreFuns.lhs \
-coreSyn/CoreUnfold.lhs \
-coreSyn/FreeVars.lhs \
-coreSyn/CoreLift.lhs \
-coreSyn/CoreLint.lhs \
-\
deSugar/Desugar.lhs \
deSugar/Match.lhs \
deSugar/MatchCon.lhs \
deSugar/DsCCall.lhs \
deSugar/DsExpr.lhs \
deSugar/DsGRHSs.lhs \
+deSugar/DsHsSyn.lhs \
deSugar/DsListComp.lhs \
deSugar/DsMonad.lhs \
deSugar/DsUtils.lhs \
\
+coreSyn/CoreLift.lhs \
+coreSyn/CoreLint.lhs
+
+#define SIMPL_SRCS_LHS \
+coreSyn/AnnCoreSyn.lhs \
+coreSyn/FreeVars.lhs \
+\
specialise/Specialise.lhs \
-specialise/SpecTyFuns.lhs \
+specialise/SpecUtils.lhs \
\
simplCore/SimplCase.lhs \
simplCore/SimplEnv.lhs \
\
simplCore/LiberateCase.lhs \
\
-simplCore/BinderInfo.lhs \
simplCore/ConFold.lhs \
simplCore/FloatIn.lhs \
simplCore/FloatOut.lhs \
-simplCore/MagicUFs.lhs \
simplCore/SAT.lhs \
simplCore/SATMonad.lhs \
simplCore/SetLevels.lhs \
simplCore/SimplCore.lhs \
simplCore/OccurAnal.lhs \
-simplCore/NewOccurAnal.lhs \
simplCore/FoldrBuildWW.lhs \
simplCore/AnalFBWW.lhs \
\
profiling/SCCfinal.lhs \
profiling/CostCentre.lhs
-#if UseSemantiqueStrictnessAnalyser != YES
-#define SEM_STRANAL_SRCS_LHS /* omit */
-#else
-#define SEM_STRANAL_SRCS_LHS \
-stranal-sem/AFE.lhs \
-stranal-sem/AbsVal.lhs \
-stranal-sem/AssocPair.lhs \
-stranal-sem/BuildAFE.lhs \
-stranal-sem/ConstrEnv.lhs \
-stranal-sem/Cycles.lhs \
-stranal-sem/FG.lhs \
-stranal-sem/FourProj.lhs \
-stranal-sem/OAL.lhs \
-stranal-sem/OAT.lhs \
-stranal-sem/OL.lhs \
-stranal-sem/ProgEnv.lhs \
-stranal-sem/ProjBasic.lhs \
-stranal-sem/ProjFactor.lhs \
-stranal-sem/ProjFolds.lhs \
-stranal-sem/ProjGets.lhs \
-stranal-sem/ProjLubAnd.lhs \
-stranal-sem/REL.lhs \
-stranal-sem/StrAnal.lhs \
-stranal-sem/StrAnn.lhs \
-stranal-sem/StrAnnCore.lhs \
-stranal-sem/StrAnnUtil.lhs \
-stranal-sem/StrTypeEnv.lhs \
-stranal-sem/Transformer.lhs \
-stranal-sem/Tree.lhs
-#endif /* UseSemantiqueStrictnessAnalyser */
-
#if GhcWithDeforester != YES
#define __omit_deforester_flag -DOMIT_DEFORESTER=1
#define DEFORESTER_SRCS_LHS /*none*/
deforest/TreelessForm.lhs
#endif /* GhcWithDeforester */
-#if BuildGHCI != YES
-#define __build_ghci_flag /*nope*/
-#define NHCSRCS_LHS /* omit */
-#define GHCISRCS_LHS /* omit */
-#else
-#define __build_ghci_flag -DBUILD_GHCI=1
-#define NHCSRCS_LHS \
-nhcParser/Parse.lhs \
-nhcParser/ParseCore.lhs \
-nhcParser/ParseLib.lhs \
-nhcParser/ParseLex.lhs \
-nhcParser/PPSyntax.lhs \
-nhcParser/PPLib.lhs \
-nhcParser/Lexical.lhs \
-nhcParser/Lex.lhs \
-nhcParser/LexPre.lhs \
-nhcParser/LexStr.lhs \
-nhcParser/HS.lhs \
-nhcParser/MkSyntax.lhs \
-nhcParser/SyntaxPos.lhs \
-nhcParser/Syntax.lhs \
-nhcParser/Extra.lhs \
-nhcParser/ScopeLib.lhs \
-nhcParser/Import.lhs \
-nhcParser/AttrLib.lhs \
-nhcParser/Attr.lhs \
-nhcParser/NHCName.lhs \
-nhcParser/NameLow.lhs \
-nhcParser/ParseI.lhs \
-nhcParser/Tree234.lhs \
-nhcParser/MergeSort.lhs \
-nhcParser/StrName.lhs \
-nhcParser/NameLib.lhs \
-nhcParser/OsOnly.lhs \
-nhcParser/Flags.lhs \
-nhcParser/Fixity.lhs \
-nhcParser/StrSyntax.lhs \
-nhcParser/Either.lhs \
-nhcParser/ListUtil.lhs \
-nhcParser/NHCPackedString.lhs \
-nhcParser/HbcOnly.lhs \
-nhcParser/LexLow.lhs
-
-/* Bits we don't need after all. ToDo: delete their source...
-nhcParser/IName.lhs \
-nhcParser/IExtract.lhs \
-nhcParser/Error.lhs \
-nhcParser/BindLib.lhs \
-nhcParser/BindI.lhs
-*/
-
-#define GHCISRCS_LHS \
-interpreter/ToPrefix.lhs \
-interpreter/UnsafeCoerce.lhs \
-interpreter/Dynamic.lhs \
-interpreter/Interpreter.lhs \
-interpreter/MkInterface.lhs \
-interpreter/GHCIMonad.lhs \
-interpreter/FullEnv.lhs \
-interpreter/Command.lhs \
-interpreter/GHCIFlags.lhs \
-interpreter/GHCInterface.lhs \
-interpreter/GHCI.lhs \
-interpreter/GHCICore.lhs \
-interpreter/Dld.lhs
-
-/* ToDo: mkworld-ify */
-DLD_DIR = ./dld
-DLD_LIB = $(DLD_DIR)/libdld.a
-DLD_INCLUDE = $(DLD_DIR)/dld.h
-
-DLD_OBJS_O = \
- dld/dld.o \
- dld/find_exec.o \
- dld/define.o \
- dld/get_func.o \
- dld/get_symbol.o \
- dld/list_undef.o \
- dld/mk_dummy.o \
- dld/ref.o \
- dld/ul_file.o \
- dld/ul_symbol.o \
- dld/remove.o \
- dld/error.o
-
-#endif /* BuildGHCI */
-
#define BACKSRCS_LHS \
stgSyn/CoreToStg.lhs \
stgSyn/StgSyn.lhs \
-stgSyn/StgFuns.lhs \
+stgSyn/StgUtils.lhs \
stgSyn/StgLint.lhs \
\
simplStg/SatStgRhs.lhs \
simplStg/StgSAT.lhs \
simplStg/SimplStg.lhs \
\
+absCSyn/AbsCUtils.lhs \
absCSyn/AbsCSyn.lhs \
+absCSyn/CLabel.lhs \
absCSyn/Costs.lhs \
absCSyn/HeapOffs.lhs \
-absCSyn/AbsCFuns.lhs \
absCSyn/PprAbsC.lhs \
\
codeGen/CodeGen.lhs \
codeGen/ClosureInfo.lhs \
codeGen/SMRep.lhs \
codeGen/CgConTbls.lhs \
-codeGen/CgCompInfo.lhs \
codeGen/CgMonad.lhs \
codeGen/CgUsages.lhs \
codeGen/CgHeapery.lhs \
distributed C files, which do not have a native-code
generator in them
*/
-#define __omit_ncg_maybe -DOMIT_NATIVE_CODEGEN=1
-#define NATIVEGEN_SRCS_LHS /*none*/
+# define __omit_ncg_maybe -DOMIT_NATIVE_CODEGEN=1
+# define NATIVEGEN_SRCS_LHS /*none*/
#else
-#define __omit_ncg_maybe /*none*/
-#if i386_TARGET_ARCH
-#define __machdep_nativegen_lhs \
+# define __omit_ncg_maybe /*none*/
+# if i386_TARGET_ARCH
+# define __machdep_nativegen_lhs \
nativeGen/I386Desc.lhs \
nativeGen/I386Code.lhs \
nativeGen/I386Gen.lhs
-#define __ghci_machdep_nativegen_lhs \
-nativeGen/I386Code.lhs
-#endif
-#if sparc_TARGET_ARCH
-#define __machdep_nativegen_lhs \
+# endif
+# if sparc_TARGET_ARCH
+# define __machdep_nativegen_lhs \
nativeGen/SparcDesc.lhs \
nativeGen/SparcCode.lhs \
nativeGen/SparcGen.lhs
-#define __ghci_machdep_nativegen_lhs \
-nativeGen/SparcCode.lhs
-#endif
-#if alpha_TARGET_ARCH
-#define __machdep_nativegen_lhs \
+# endif
+# if alpha_TARGET_ARCH
+# define __machdep_nativegen_lhs \
nativeGen/AlphaDesc.lhs \
nativeGen/AlphaCode.lhs \
nativeGen/AlphaGen.lhs
-#define __ghci_machdep_nativegen_lhs \
-nativeGen/AlphaCode.lhs
-#endif
+# endif
-#define NATIVEGEN_SRCS_LHS \
+# define NATIVEGEN_SRCS_LHS \
nativeGen/AbsCStixGen.lhs \
nativeGen/AsmCodeGen.lhs \
nativeGen/AsmRegAlloc.lhs \
#endif
#define UTILSRCS_LHS \
-utils/CharSeq.lhs \
+utils/Argv.lhs \
utils/Bag.lhs \
-utils/Pretty.lhs \
-utils/Unpretty.lhs \
-utils/Maybes.lhs \
-utils/Digraph.lhs \
utils/BitSet.lhs \
-utils/LiftMonad.lhs \
+utils/CharSeq.lhs \
+utils/Digraph.lhs \
+utils/FiniteMap.lhs \
utils/ListSetOps.lhs \
+utils/MatchEnv.lhs \
+utils/Maybes.lhs \
+utils/OrdList.lhs \
utils/Outputable.lhs \
-utils/FiniteMap.lhs \
+utils/PprStyle.lhs \
+utils/Pretty.lhs \
+utils/SST.lhs \
utils/UniqFM.lhs \
utils/UniqSet.lhs \
+utils/Unpretty.lhs \
utils/Util.lhs
-#if BuildDataParallelHaskell != YES
-#define DPH_SRCS_LHS /*none*/
-#else
-#define DPH_SRCS_LHS \
-\
-typecheck/TcParQuals.lhs \
-deSugar/DsParZF.lhs \
-deSugar/MatchProc.lhs \
-prelude/ClsPid.lhs \
-prelude/ClsProc.lhs \
-prelude/TyPod.lhs \
-prelude/TyProcs.lhs \
-\
-podizeCore/PodInfoTree.lhs \
-podizeCore/PodInfoMonad.lhs \
-podizeCore/PodInfo1.lhs \
-podizeCore/PodInfo2.lhs \
-podizeCore/PodizeMonad.lhs \
-podizeCore/PodizePass0.lhs \
-podizeCore/PodizePass1.lhs \
-podizeCore/PodizePass2.lhs \
-podizeCore/PodizeCore.lhs
-#endif /* DPH */
-
#define MAIN_SRCS_LHS \
-main/MkIface.lhs \
-main/ErrUtils.lhs \
-main/ErrsRn.lhs \
-main/ErrsTc.lhs \
-main/Errors.lhs \
main/MainMonad.lhs \
main/CmdLineOpts.lhs \
+main/ErrUtils.lhs \
main/Main.lhs
+/*
+main/MkIface.lhs \
+*/
+
+#define VBASICSRCS_LHS \
+prelude/PrelMods.lhs \
+prelude/PrimRep.lhs \
+prelude/PrimOp.lhs \
+prelude/TysPrim.lhs \
+prelude/TysWiredIn.lhs \
+prelude/PrelVals.lhs \
+prelude/PrelInfo.lhs \
+\
+absCSyn/CStrings.lhs \
+codeGen/CgCompInfo.lhs \
+coreSyn/CoreSyn.lhs \
+coreSyn/CoreUnfold.lhs \
+coreSyn/CoreUtils.lhs \
+coreSyn/PprCore.lhs \
+profiling/CostCentre.lhs \
+simplCore/BinderInfo.lhs \
+simplCore/MagicUFs.lhs
+
ALLSRCS_HS = READERSRCS_HS
ALLSRCS_LHS = /* all pieces of the compiler */ \
-READERSRCS_LHS \
-FRONTSRCS_LHS \
-TCSRCS_LHS \
-DSSRCS_LHS \
-BACKSRCS_LHS \
+VBASICSRCS_LHS \
+NOT_SO_BASICSRCS_LHS \
+UTILSRCS_LHS \
MAIN_SRCS_LHS \
-UTILSRCS_LHS NATIVEGEN_SRCS_LHS DEFORESTER_SRCS_LHS SEM_STRANAL_SRCS_LHS DPH_SRCS_LHS NHCSRCS_LHS GHCISRCS_LHS
-/* NB: all the ones that may be empty (e.g., DPH_SRCS_LHS)
- need to be on the last line.
-*/
-
-HSCSRCS_HS = READERSRCS_HS
-HSCSRCS_LHS = /* all pieces of the compiler */ \
READERSRCS_LHS \
-FRONTSRCS_LHS \
+RENAMERSRCS_LHS \
TCSRCS_LHS \
-DSSRCS_LHS \
-BACKSRCS_LHS \
-MAIN_SRCS_LHS \
-UTILSRCS_LHS NATIVEGEN_SRCS_LHS DEFORESTER_SRCS_LHS SEM_STRANAL_SRCS_LHS DPH_SRCS_LHS
-
-/*
-As well as the obvious inclusions, there are a few non-obvious ones
-obtained from the transitive closure:
-
-* main/Errors.lhs andmain/CmdLineOpts.lhs are actually used.
-
-* most of the rest trickles in through the prelude.
-
-ToDo: hack around in the prelude to avoid all this...
+DSSRCS_LHS
+/*
+SIMPL_SRCS_LHS
+BACKSRCS_LHS
*/
-GHCISRCS = /* all pieces of the interpreter */ \
-FRONTSRCS_LHS \
-TCSRCS_LHS \
-DSSRCS_LHS \
-main/Errors.lhs \
-main/ErrUtils.lhs \
-main/ErrsRn.lhs \
-main/ErrsTc.lhs \
-main/CmdLineOpts.lhs \
-main/MainMonad.lhs \
-absCSyn/HeapOffs.lhs \
-codeGen/SMRep.lhs \
-codeGen/CgCompInfo.lhs \
-codeGen/ClosureInfo.lhs \
-codeGen/CgRetConv.lhs \
-absCSyn/AbsCSyn.lhs \
-codeGen/CgMonad.lhs \
-absCSyn/AbsCFuns.lhs \
-codeGen/CgBindery.lhs \
-codeGen/CgUsages.lhs \
-absCSyn/Costs.lhs \
-absCSyn/PprAbsC.lhs \
-stgSyn/StgSyn.lhs \
-nativeGen/AsmRegAlloc.lhs __ghci_machdep_nativegen_lhs \
-UTILSRCS_LHS SEM_STRANAL_SRCS_LHS DEFORESTER_SRCS_LHS NHCSRCS_LHS GHCISRCS_LHS
-
+/*
+NATIVEGEN_SRCS_LHS DEFORESTER_SRCS_LHS */
+/* NB: all the ones that may be empty (e.g., NATIVEGEN_SRCS_LHS)
+ need to be on the last line.
+*/
/* should't use these fancy `make' things, really */
+ALLHCS =$(ALLSRCS_LHS:.lhs=.hc) $(ALLSRCS_HS:.hs=.hc)
ALLOBJS=$(ALLSRCS_LHS:.lhs=.o) $(ALLSRCS_HS:.hs=.o)
ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi)
-HSCOBJS=$(HSCSRCS_LHS:.lhs=.o) $(HSCSRCS_HS:.hs=.o)
-HSCINTS=$(HSCSRCS_LHS:.lhs=.hi) $(HSCSRCS_HS:.hs=.hi)
-
-GHCIOBJS=$(GHCISRCS:.lhs=.o) interpreter/DldHacks.o interpreter/DldC.o interpreter/prelude.o interpreter/runtime.o
-GHCIINTS=$(GHCISRCS:.lhs=.hi) interpreter/Dldhacks.hi
-
.PRECIOUS: $(ALLINTS)
#if GhcWithHscDebug == YES
# define use_DDEBUG /*nothing*/
#endif
-#if HaskellCompilerType == HC_CHALMERS_HBC
-
-HC_OPTS = -D__HASKELL1__=2 -M -H12m -DCOMPILING_GHC use_DDEBUG -I. -i$(SUBDIR_LIST)
-
-/* ToDo: else something for Niklas Rojemo's NHC (not yet) */
-
-#else /* assume we either have GlasgowHaskell or are booting from .hc C files */
-
#if GhcWithHscOptimised == YES
#define __version_sensitive_flags -DUSE_ATTACK_PRAGMAS -fshow-pragma-name-errs -fomit-reexported-instances -fshow-import-specs
#else
#undef AllProjectsHcOpts
#define AllProjectsHcOpts /**/
-HC_OPTS = -cpp -H12m HcMaxHeapFlag -fglasgow-exts -DCOMPILING_GHC \
+HC_OPTS = -cpp HcMaxHeapFlag -fhaskell-1.3 -fglasgow-exts -DCOMPILING_GHC \
-fomit-derived-read \
-I. -i$(SUBDIR_LIST) \
- use_DDEBUG __version_sensitive_flags __unreg_opts_maybe __omit_ncg_maybe __new_reader_flag __build_ghci_flag __omit_deforester_flag
+ use_DDEBUG __version_sensitive_flags __unreg_opts_maybe __omit_ncg_maybe
#undef __version_sensitive_flags
#undef __unreg_opts_maybe
#undef __omit_ncg_maybe
-#undef __new_reader_flag
-#undef __build_ghci_flag
#undef __omit_deforester_flag
#if GhcWithHscBuiltViaC == YES /* not using a Haskell compiler */
-HSCHCS=$(HSCSRCS_LHS:.lhs=.hc) $(HSCSRCS_HS:.hs=.hc)
-hcs:: $(HSCHCS)
+hcs:: $(ALLHCS)
-#if HaskellCompilerType == HC_USE_HC_FILES
+# if HaskellCompilerType == HC_USE_HC_FILES
HC = $(GHC) /* uses the driver herein */
-#endif
+# endif
#endif /* using .hc files */
-#endif /* not using HBC */
/*
-DCOMPILING_GHC
- we're compiling the compiler with itself; clear enough?
- Only used at present to ask for SPECIALIZEd functions
- in modules that are allegedly "generic" (e.g., FiniteMap).
-
- -DUSE_SEMANTIQUE_STRANAL
- to include the Semantique strictness analyser into the compiler
- [probably quite moth-eaten by now 94/05 (WDP)]
-
- -DDPH compiling Jon Hill's "data parallel Haskell"
-
- (there are more, as yet unlisted WDP 94/12)
+ Used when compiling GHC. Some GHC utility modules are
+ *also* part of the GHC library. There are a few bits
+ of those modules that only apply to GHC itself and
+ should not be in the library stuff. We use this
+ CPP thing to isolate those bits.
*/
-#if UseSemantiqueStrictnessAnalyser == YES
-STRANAL_SEM_P = -DUSE_SEMANTIQUE_STRANAL
-#endif
-
-#if BuildDataParallelHaskell == YES
-DPH_P = -DDPH
-#endif
-#if GhcUseSplittableUniqueSupply == YES
-/* ToDo: delete? */
-SPLIT_P = -DUSE_SPLITTABLE_UNIQUESUPPLY
-#endif
-
-GHC_EXTRA_DEFINES = $(STRANAL_SEM_P) $(DPH_P) $(SPLIT_P)
-
-#if USE_NEW_READER == YES
-BuildPgmFromHaskellModules(hsc,$(HSCOBJS) yaccParser/hsclink.o yaccParser/hschooks.o,,libhsp.a)
-#else
-BuildPgmFromHaskellModules(hsc,$(HSCOBJS),,)
-#endif
-
-/* ghci:: hsc */
-/* Hack to let me bootstrap (needed for error handlers) */
-/* Comment out if building boot copy of hsc */
-/*HC = ../driver/ghc*/
-#if BuildGHCI == YES
-BuildPgmFromHaskellModules(ghci,$(GHCIOBJS),,$(DLD_LIB))
-#endif
+BuildPgmFromHaskellModules(hsc,$(ALLOBJS) parser/hsclink.o parser/hschooks.o,,libhsp.a)
#if DoInstallGHCSystem == YES
MakeDirectories(install, $(INSTLIBDIR_GHC))
#endif /* ! booting from C */
-#if HaskellCompilerType == HC_CHALMERS_HBC
-# define if_ghc(x) /*nothing*/
-# define if_ghc26(x) /*nothing*/
-#else /* hope for GHC-ish */
-# define if_ghc(x) x
-# if GhcBuilderVersion >= 26
+#define if_ghc(x) x
+#if GhcBuilderVersion >= 26
# define if_ghc26(x) x
-# else
+#else
# define if_ghc26(x) /*nothing*/
-# endif
#endif
/* OK, here we go: */
-compile(absCSyn/AbsCFuns,lhs,)
-compile_rec(absCSyn/AbsCSyn,lhs,if_ghc(-fno-omit-reexported-instances))
-compile(absCSyn/Costs,lhs,) /* HWL */
-compile_rec(absCSyn/HeapOffs,lhs,)
-compile(absCSyn/PprAbsC,lhs,-H20m)
-
-compile_rec(abstractSyn/AbsSyn,lhs,if_ghc(-fno-omit-reexported-instances))
-compile_rec(abstractSyn/AbsSynFuns,lhs,)
-compile_rec(abstractSyn/HsBinds,lhs,)
-compile_rec(abstractSyn/HsCore,lhs,)
-compile(abstractSyn/HsDecls,lhs,)
-compile_rec(abstractSyn/HsExpr,lhs,-H14m)
-compile(abstractSyn/HsImpExp,lhs,)
-compile(abstractSyn/HsLit,lhs,)
-compile(abstractSyn/HsMatches,lhs,)
-compile(abstractSyn/HsPat,lhs,)
-compile_rec(abstractSyn/HsPragmas,lhs,)
-compile(abstractSyn/HsTypes,lhs,)
-compile_rec(abstractSyn/Name,lhs,)
-
-compile(basicTypes/BasicLit,lhs,)
-compile(basicTypes/OrdList,lhs,)
-compile_rec(basicTypes/CLabelInfo,lhs,)
-compile_rec(basicTypes/Id,lhs,-H20m)
-compile_rec(basicTypes/IdInfo,lhs,-H20m -K2m)
-compile(basicTypes/Inst,lhs,)
+utils/Ubiq.hi : utils/Ubiq.lhi
+ $(GHC_UNLIT) utils/Ubiq.lhi utils/Ubiq.hi
+
+basicTypes/IdLoop.hi : basicTypes/IdLoop.lhi
+ $(GHC_UNLIT) basicTypes/IdLoop.lhi basicTypes/IdLoop.hi
+basicTypes/NameLoop.hi : basicTypes/NameLoop.lhi
+ $(GHC_UNLIT) basicTypes/NameLoop.lhi basicTypes/NameLoop.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
+prelude/PrelLoop.hi : prelude/PrelLoop.lhi
+ $(GHC_UNLIT) prelude/PrelLoop.lhi prelude/PrelLoop.hi
+reader/RdrLoop.hi : reader/RdrLoop.lhi
+ $(GHC_UNLIT) reader/RdrLoop.lhi reader/RdrLoop.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
+
+compile(absCSyn/AbsCUtils,lhs,)
+compile(absCSyn/CStrings,lhs,)
+compile(absCSyn/CLabel,lhs,)
+compile(absCSyn/Costs,lhs,)
+compile(absCSyn/HeapOffs,lhs,)
+compile(absCSyn/PprAbsC,lhs,)
+compile(absCSyn/AbsCSyn,lhs,if_ghc(-fno-omit-reexported-instances))
+
+compile(hsSyn/HsBinds,lhs,)
+compile(hsSyn/HsCore,lhs,)
+compile(hsSyn/HsDecls,lhs,)
+compile(hsSyn/HsExpr,lhs,)
+compile(hsSyn/HsImpExp,lhs,)
+compile(hsSyn/HsLit,lhs,)
+compile(hsSyn/HsMatches,lhs,)
+compile(hsSyn/HsPat,lhs,)
+compile(hsSyn/HsPragmas,lhs,)
+compile(hsSyn/HsTypes,lhs,)
+compile(hsSyn/HsSyn,lhs,if_ghc(-fno-omit-reexported-instances))
+
+compile(basicTypes/Id,lhs,)
+compile(basicTypes/IdInfo,lhs,-K2m)
+compile(basicTypes/IdUtils,lhs,)
+compile(basicTypes/Literal,lhs,)
+compile(basicTypes/Name,lhs,)
compile(basicTypes/NameTypes,lhs,)
+compile(basicTypes/PragmaInfo,lhs,)
compile(basicTypes/ProtoName,lhs,)
compile(basicTypes/SrcLoc,lhs,)
+compile(basicTypes/UniqSupply,lhs,)
compile(basicTypes/Unique,lhs,)
-compile_rec(basicTypes/SplitUniq,lhs,)
compile(codeGen/CgBindery,lhs,)
-compile(codeGen/CgCase,lhs,-H16m)
-compile(codeGen/CgClosure,lhs,-H16m)
-compile_rec(codeGen/CgCompInfo,lhs,-I$(COMPINFO_DIR))
+compile(codeGen/CgCase,lhs,)
+compile(codeGen/CgClosure,lhs,)
+compile(codeGen/CgCompInfo,lhs,-I$(COMPINFO_DIR))
compile(codeGen/CgCon,lhs,)
compile(codeGen/CgConTbls,lhs,)
-compile_rec(codeGen/CgExpr,lhs,)
+compile(codeGen/CgExpr,lhs,)
compile(codeGen/CgHeapery,lhs,)
compile(codeGen/CgLetNoEscape,lhs,)
-compile_rec(codeGen/CgMonad,lhs,if_ghc(-fno-omit-reexported-instances))
-compile_rec(codeGen/CgRetConv,lhs,)
+compile(codeGen/CgMonad,lhs,)
+compile(codeGen/CgRetConv,lhs,)
compile(codeGen/CgStackery,lhs,)
compile(codeGen/CgTailCall,lhs,)
compile(codeGen/CgUpdate,lhs,)
compile(codeGen/CgUsages,lhs,)
-compile_rec(codeGen/ClosureInfo,lhs,)
+compile(codeGen/ClosureInfo,lhs,)
compile(codeGen/CodeGen,lhs,)
compile(codeGen/SMRep,lhs,)
compile(coreSyn/AnnCoreSyn,lhs,if_ghc(-fno-omit-reexported-instances))
-compile(coreSyn/CoreFuns,lhs,-H16m)
+compile(coreSyn/CoreUtils,lhs,)
compile(coreSyn/CoreLift,lhs,)
compile(coreSyn/CoreLint,lhs,)
compile(coreSyn/CoreSyn,lhs,)
+compile(coreSyn/PprCore,lhs,)
compile(coreSyn/CoreUnfold,lhs,)
compile(coreSyn/FreeVars,lhs,)
-compile_rec(coreSyn/PlainCore,lhs,if_ghc(-fno-omit-reexported-instances))
-compile(coreSyn/TaggedCore,lhs,if_ghc(-fno-omit-reexported-instances))
compile(deSugar/Desugar,lhs,)
-compile_rec(deSugar/DsBinds,lhs,-H16m)
+compile(deSugar/DsBinds,lhs,)
compile(deSugar/DsCCall,lhs,)
-compile_rec(deSugar/DsExpr,lhs,-H16m)
+compile(deSugar/DsExpr,lhs,)
compile(deSugar/DsGRHSs,lhs,)
+compile(deSugar/DsHsSyn,lhs,)
compile(deSugar/DsListComp,lhs,)
compile(deSugar/DsMonad,lhs,)
-compile_rec(deSugar/DsUtils,lhs,)
-compile_rec(deSugar/Match,lhs,)
+compile(deSugar/DsUtils,lhs,)
+compile(deSugar/Match,lhs,)
compile(deSugar/MatchCon,lhs,)
compile(deSugar/MatchLit,lhs,)
-compile(envs/CE,lhs,)
-compile(envs/E,lhs,)
-compile(envs/IdEnv,lhs,)
-compile_rec(envs/InstEnv,lhs,)
-compile(envs/LIE,lhs,)
-compile(envs/TCE,lhs,)
-compile(envs/TVE,lhs,)
-compile_rec(envs/TyVarEnv,lhs,)
-
-compile(main/CmdLineOpts,lhs,-K2m if_ghc(-fvia-C))
-compile_rec(main/Errors,lhs,)
-compile_rec(main/ErrsTc,lhs,-H20m if_ghc26(-monly-4-regs))
-compile_rec(main/ErrsRn,lhs,)
-compile_rec(main/ErrUtils,lhs,)
-compile(main/Main,lhs,-H16m if_ghc(-fvia-C -fno-update-analysis)) /* ToDo: update */
-compile(main/MainMonad,lhs,if_ghc(-fno-omit-reexported-instances))
+compile(main/CmdLineOpts,lhs,if_ghc(-fvia-C))
+compile(main/ErrUtils,lhs,)
+compile(main/Main,lhs,if_ghc(-fvia-C))
+compile(main/MainMonad,lhs,)
compile(main/MkIface,lhs,)
#if GhcWithNativeCodeGen == YES
compile(nativeGen/AbsCStixGen,lhs,)
compile(nativeGen/AsmCodeGen,lhs,-I$(COMPINFO_DIR))
-compile_rec(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR) -H20m)
+compile(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR))
compile(nativeGen/MachDesc,lhs,)
compile(nativeGen/Stix,lhs,)
compile(nativeGen/StixInfo,lhs,-I$(NATIVEGEN_DIR))
-compile(nativeGen/StixInteger,lhs,-H20m)
+compile(nativeGen/StixInteger,lhs,)
compile(nativeGen/StixMacro,lhs,-I$(NATIVEGEN_DIR))
-compile(nativeGen/StixPrim,lhs,-H16m)
+compile(nativeGen/StixPrim,lhs,)
# if i386_TARGET_ARCH
-compile_rec(nativeGen/I386Desc,lhs,)
-compile(nativeGen/I386Code,lhs,-H20m -I$(NATIVEGEN_DIR) if_ghc(-monly-4-regs))
-compile(nativeGen/I386Gen,lhs,-H20m)
+compile(nativeGen/I386Desc,lhs,)
+compile(nativeGen/I386Code,lhs,-I$(NATIVEGEN_DIR) if_ghc(-monly-4-regs))
+compile(nativeGen/I386Gen,lhs,)
# endif
# if sparc_TARGET_ARCH
-compile_rec(nativeGen/SparcDesc,lhs,)
-compile(nativeGen/SparcCode,lhs,-H20m -I$(NATIVEGEN_DIR))
-compile(nativeGen/SparcGen,lhs,-H20m)
+compile(nativeGen/SparcDesc,lhs,)
+compile(nativeGen/SparcCode,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/SparcGen,lhs,)
# endif
# if alpha_TARGET_ARCH
-compile_rec(nativeGen/AlphaDesc,lhs,)
-compile(nativeGen/AlphaCode,lhs,-H24m -K2m -I$(NATIVEGEN_DIR))
-compile(nativeGen/AlphaGen,lhs,-H24m -K2m)
+compile(nativeGen/AlphaDesc,lhs,)
+compile(nativeGen/AlphaCode,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/AlphaGen,lhs,)
# endif
#endif
-compile_rec(prelude/AbsPrel,lhs,-H16m -K2m if_ghc(-fno-omit-reexported-instances -fno-update-analysis))
-compile_rec(prelude/PrelFuns,lhs,)
+compile(prelude/PrelInfo,lhs,)
+compile(prelude/PrelMods,lhs,)
compile(prelude/PrelVals,lhs,)
-compile_rec(prelude/PrimKind,lhs,-I$(COMPINFO_DIR))
-compile_rec(prelude/PrimOps,lhs,-H16m -K3m)
+compile(prelude/PrimRep,lhs,-I$(COMPINFO_DIR))
+compile(prelude/PrimOp,lhs,-K3m -H10m)
compile(prelude/TysPrim,lhs,)
compile(prelude/TysWiredIn,lhs,)
compile(profiling/CostCentre,lhs,)
compile(reader/PrefixSyn,lhs,)
-compile(reader/PrefixToHs,lhs,-H16m)
+compile(reader/PrefixToHs,lhs,)
+compile(reader/ReadPrefix,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -Iparser '-#include"hspincl.h"'))
compile(reader/ReadPragmas,lhs,)
-compile_rec(reader/ReadPrefix,lhs,)
-compile_rec(reader/ReadPrefix2,lhs,-H20m if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(reader/ReadPragmas2,lhs,-H20m)
+compile(reader/RdrHsSyn,lhs,)
compile(rename/Rename,lhs,)
-compile(rename/Rename1,lhs,)
-compile(rename/Rename2,lhs,)
-compile(rename/Rename3,lhs,)
-compile(rename/Rename4,lhs,-H20m)
-compile(rename/RenameAuxFuns,lhs,)
-compile_rec(rename/RenameBinds4,lhs,)
-compile_rec(rename/RenameExpr4,lhs,)
-compile(rename/RenameMonad12,lhs,)
-compile(rename/RenameMonad3,lhs,)
-compile(rename/RenameMonad4,lhs,)
+compile(rename/RnPass1,lhs,)
+compile(rename/RnPass2,lhs,)
+compile(rename/RnPass3,lhs,)
+compile(rename/RnPass4,lhs,)
+compile(rename/RnUtils,lhs,)
+compile(rename/RnHsSyn,lhs,)
+compile(rename/RnBinds4,lhs,)
+compile(rename/RnExpr4,lhs,)
+compile(rename/RnMonad12,lhs,)
+compile(rename/RnMonad3,lhs,)
+compile(rename/RnMonad4,lhs,)
compile(simplCore/BinderInfo,lhs,)
compile(simplCore/ConFold,lhs,)
compile(simplCore/MagicUFs,lhs,)
compile(simplCore/OccurAnal,lhs,)
-compile(simplCore/NewOccurAnal,lhs,)
compile(simplCore/AnalFBWW,lhs,)
compile(simplCore/FoldrBuildWW,lhs,)
-/* ANDY: compile(simplCore/SimplHaskell,lhs,) */
compile(simplCore/SAT,lhs,)
compile(simplCore/SATMonad,lhs,)
compile(simplCore/SetLevels,lhs,)
-compile_rec(simplCore/SimplCase,lhs,-H20m)
+compile(simplCore/SimplCase,lhs,)
compile(simplCore/SimplCore,lhs,)
-compile_rec(simplCore/SimplEnv,lhs,)
+compile(simplCore/SimplEnv,lhs,)
compile(simplCore/SimplMonad,lhs,)
compile(simplCore/SimplPgm,lhs,)
compile(simplCore/SimplUtils,lhs,)
-compile_rec(simplCore/SimplVar,lhs,)
+compile(simplCore/SimplVar,lhs,)
compile(simplCore/Simplify,lhs,)
compile(simplStg/SatStgRhs,lhs,)
#if GhcWithDeforester == YES
compile(deforest/Core2Def,lhs,)
compile(deforest/Cyclic,lhs,)
-compile_rec(deforest/Def2Core,lhs,)
-compile(deforest/DefExpr,lhs,-H20m)
+compile(deforest/Def2Core,lhs,)
+compile(deforest/DefExpr,lhs,)
compile(deforest/DefSyn,lhs,)
-compile(deforest/DefUtils,lhs,-H16m)
+compile(deforest/DefUtils,lhs,)
compile(deforest/Deforest,lhs,)
compile(deforest/TreelessForm,lhs,)
#endif
-compile(specialise/Specialise,lhs,-H32m) /* sigh */
-compile(specialise/SpecTyFuns,lhs,)
+compile(specialise/Specialise,lhs,)
+compile(specialise/SpecEnv,lhs,)
+compile(specialise/SpecUtils,lhs,)
compile(stgSyn/CoreToStg,lhs,)
-compile(stgSyn/StgFuns,lhs,)
+compile(stgSyn/StgUtils,lhs,)
compile(stgSyn/StgLint,lhs,)
-compile(stgSyn/StgSyn,lhs,if_ghc(-fno-omit-reexported-instances) -H16m)
+compile(stgSyn/StgSyn,lhs,if_ghc(-fno-omit-reexported-instances))
compile(stranal/SaAbsInt,lhs,)
compile(stranal/SaLib,lhs,)
compile(stranal/WorkWrap,lhs,)
compile(stranal/WwLib,lhs,)
-compile(typecheck/BackSubst,lhs,)
-compile_rec(typecheck/Disambig,lhs,)
compile(typecheck/GenSpecEtc,lhs,)
-compile(typecheck/Spec,lhs,)
-compile(typecheck/Subst,lhs,if_ghc(-fvia-C) if_ghc26(-monly-4-regs))
+compile(typecheck/Inst,lhs,)
+compile(typecheck/TcHsSyn,lhs,)
compile(typecheck/TcBinds,lhs,)
-compile(typecheck/TcClassDcl,lhs,-H14m)
-compile(typecheck/TcClassSig,lhs,)
-compile(typecheck/TcConDecls,lhs,)
-compile(typecheck/TcContext,lhs,)
+compile(typecheck/TcClassDcl,lhs,)
compile(typecheck/TcDefaults,lhs,)
-compile_rec(typecheck/TcDeriv,lhs,-H20m)
-compile_rec(typecheck/TcExpr,lhs,-H20m)
-compile_rec(typecheck/TcGRHSs,lhs,)
-compile(typecheck/TcGenDeriv,lhs,-H20m)
+compile(typecheck/TcDeriv,lhs,)
+compile(typecheck/TcExpr,lhs,)
+compile(typecheck/TcGRHSs,lhs,)
+compile(typecheck/TcGenDeriv,lhs,)
compile(typecheck/TcIfaceSig,lhs,)
-compile(typecheck/TcInstDcls,lhs,-H20m)
+compile(typecheck/TcInstDcls,lhs,)
+compile(typecheck/TcInstUtil,lhs,)
compile(typecheck/TcMatches,lhs,)
compile(typecheck/TcModule,lhs,)
-compile_rec(typecheck/TcMonad,lhs,)
-compile(typecheck/TcMonadFns,lhs,)
-compile(typecheck/TcMonoBnds,lhs,)
+compile(typecheck/TcMonad,lhs,)
+compile(typecheck/TcKind,lhs,)
+compile(typecheck/TcType,lhs,)
+compile(typecheck/TcEnv,lhs,)
compile(typecheck/TcMonoType,lhs,)
-compile(typecheck/TcPat,lhs,-H14m)
-compile_rec(typecheck/TcPolyType,lhs,)
-compile(typecheck/TcPragmas,lhs,-H20m)
-compile(typecheck/TcQuals,lhs,)
+compile(typecheck/TcPat,lhs,)
+compile(typecheck/TcPragmas,lhs,)
compile(typecheck/TcSimplify,lhs,)
+compile(typecheck/TcTyClsDecls,lhs,)
compile(typecheck/TcTyDecls,lhs,)
compile(typecheck/Typecheck,lhs,)
compile(typecheck/Unify,lhs,)
-compile_rec(uniType/AbsUniType,lhs,if_ghc(-fno-omit-reexported-instances))
-compile_rec(uniType/Class,lhs,)
-compile_rec(uniType/TyCon,lhs,)
-compile_rec(uniType/TyVar,lhs,)
-compile(uniType/UniTyFuns,lhs,-H20m)
-compile_rec(uniType/UniType,lhs,)
+compile(types/Class,lhs,)
+compile(types/Kind,lhs,)
+compile(types/PprType,lhs,)
+compile(types/TyCon,lhs,)
+compile(types/TyVar,lhs,)
+compile(types/Usage,lhs,)
+compile(types/Type,lhs,)
+compile(utils/Argv,lhs,if_ghc(-fvia-C))
compile(utils/Bag,lhs,)
+compile(utils/BitSet,lhs,if_ghc26(-monly-4-regs))
compile(utils/CharSeq,lhs,if_ghc(-fvia-C)) /* uses stg_putc */
compile(utils/Digraph,lhs,)
-compile(utils/FiniteMap,lhs,-H20m)
-compile(utils/LiftMonad,lhs,)
+compile(utils/FiniteMap,lhs,)
compile(utils/ListSetOps,lhs,)
compile(utils/Maybes,lhs,)
-compile_rec(utils/Outputable,lhs,)
-compile_rec(utils/Pretty,lhs,)
-compile(utils/BitSet,lhs,if_ghc26(-monly-4-regs))
-compile_rec(utils/UniqFM,lhs,)
+compile(utils/OrdList,lhs,)
+compile(utils/Outputable,lhs,)
+compile(utils/PprStyle,lhs,)
+compile(utils/Pretty,lhs,)
+compile(utils/SST,lhs,if_ghc(-fvia-C))
+compile(utils/UniqFM,lhs,)
compile(utils/UniqSet,lhs,)
compile(utils/Unpretty,lhs,)
-compile_rec(utils/Util,lhs,)
-
-/* Some of these sizes have been boosted a little to fit the alpha */
-#if BuildGHCI == YES
-compile(nhcParser/Attr,lhs,)
-compile(nhcParser/AttrLib,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Either,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Extra,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Fixity,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Flags,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/HS,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/HbcOnly,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/Import,lhs,)
-compile(nhcParser/Lex,lhs,)
-compile(nhcParser/LexLow,lhs,)
-compile(nhcParser/LexPre,lhs,)
-compile(nhcParser/LexStr,lhs,)
-compile(nhcParser/Lexical,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ListUtil,lhs,)
-compile(nhcParser/MergeSort,lhs,)
-compile(nhcParser/MkSyntax,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/NHCName,lhs,)
-compile(nhcParser/NHCPackedString,lhs,)
-compile(nhcParser/NameLib,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/NameLow,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/OsOnly,lhs,)
-compile(nhcParser/PPLib,lhs,)
-compile(nhcParser/PPSyntax,lhs,)
-compile(nhcParser/Parse,lhs,-H30m if_ghc(-fhaskell-1.3))
-compile(nhcParser/ParseCore,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ParseI,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ParseLex,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ParseLib,lhs,if_ghc(-fhaskell-1.3))
-compile(nhcParser/ScopeLib,lhs,)
-compile(nhcParser/StrName,lhs,)
-compile(nhcParser/StrSyntax,lhs,)
-compile(nhcParser/Syntax,lhs,)
-compile(nhcParser/SyntaxPos,lhs,)
-compile(nhcParser/Tree234,lhs,)
-
-compile(interpreter/ToPrefix,lhs,if_ghc(-fhaskell-1.3))
-compile(interpreter/UnsafeCoerce,lhs,if_ghc(-nohi)) /* NB: no interface file, please! */
-compile(interpreter/Dynamic,lhs,)
-compile(interpreter/Interpreter,lhs,if_ghc(-fvia-C -fhaskell-1.3))
-compile(interpreter/MkInterface,lhs,)
-compile(interpreter/GHCIMonad,lhs,if_ghc(-fvia-C -fhaskell-1.3))
-compile(interpreter/FullEnv,lhs,if_ghc(-fhaskell-1.3))
-compile(interpreter/Command,lhs,)
-compile(interpreter/GHCIFlags,lhs,)
-compile(interpreter/GHCInterface,lhs,-H40m if_ghc(-fhaskell-1.3))
-compile(interpreter/GHCI,lhs,if_ghc(-fhaskell-1.3))
-compile(interpreter/GHCICore,lhs,if_ghc(-fhaskell-1.3))
-
-# Just using standard macro doesn't use the #include then compiling the
-# .hc file.
-
-HaskellCompileWithExtraFlags(interpreter/Dld,lhs,hc,-fvia-C -C -fhaskell-1.3,)
-HaskellCompileWithExtraFlags_Recursive(interpreter/Dld,hc,o,-c,'-#include"$(DLD_INCLUDE)"')
-
-# (There's gotta be a cleaner way of doing this but only one person in
-# the entire world understands Jmakefiles well enough to use them
-# effectively.)
-
-# some c-as-asm level hacks
-# also needs a hand-hacked interface file
-interpreter/DldHacks.o: interpreter/DldHacks.lhc
- $(RM) interpreter/DldHacks.hc interpreter/DldHacks.o
- lit2pgm interpreter/DldHacks.lhc
- $(GHC) -c $(GHC_FLAGS) interpreter/DldHacks.hc
-
-interpreter/DldC.o: interpreter/DldC.lc
- $(RM) interpreter/DldC.c interpreter/DldC.o
- lit2pgm interpreter/DldC.lc
- $(GHC) -c $(GHC_FLAGS) interpreter/DldC.c -I$(DLD_DIR) -optcO-DNON_POSIX_SOURCE
-
-/* Does not work for a subdir ... (Sigh)
-NormalLibraryTarget($(DLD_DIR)/libdld,$(DLD_OBJS_O))
-*/
-all :: dld/libdld.a
-clean ::
- $(RM) dld/libdld.a
-dld/libdld.a :: $(DLD_OBJS_O)
- $(RM) $@
- $(AR) $@ $(DLD_OBJS_O)
- $(RANLIB) $@
-
-# To improve loading speed, we generate some C programs which contain
-# references to all symbols in the libraries we link with.
-
-# ToDo: remove the appel dependency.
-
-MY_TOP = ..
-MY_LIB = $(MY_TOP)/lib
-MY_RTS = $(MY_TOP)/runtime
-
-interpreter/prelude.o: $(MY_LIB)/libHS.a makeSymbolList.prl
- $(RM) interpreter/prelude.c interpreter/prelude.o
- nm -p $(MY_LIB)/libHS.a | perl makeSymbolList.prl > interpreter/prelude.c
- $(GHC) -c $(GHC_FLAGS) interpreter/prelude.c
-
-interpreter/runtime.o: $(MY_RTS)/libHSrts.a $(MY_RTS)/libHSclib.a makeSymbolList.prl
- $(RM) interpreter/runtime.c interpreter/runtime.o
- nm -p $(MY_RTS)/libHSrts.a $(MY_RTS)/libHSclib.a | perl makeSymbolList.prl > interpreter/runtime.c
- $(GHC) -c $(GHC_FLAGS) interpreter/runtime.c
-
-#endif /* GHCI */
+compile(utils/MatchEnv,lhs,)
+compile(utils/Util,lhs,)
/* for convenience in cross-compiling */
objs:: $(ALLOBJS)
/* *** parser ************************************************* */
YACC_OPTS = -d
-CC_OPTS = -IyaccParser -I. -I$(COMPINFO_DIR)
+CC_OPTS = -Iparser -I. -I$(COMPINFO_DIR) -DUGEN_DEBUG=1 /*-DHSP_DEBUG=1*/ -g
/* add to these on the command line with, e.g., EXTRA_YACC_OPTS=-v */
-#if BuildDataParallelHaskell == YES
-D_DPH = -DDPH
-#endif
-
XCOMM D_DEBUG = -DDEBUG
-CPP_DEFINES = $(D_DEBUG) $(D_DPH)
-
-HSP_SRCS_C = /* yaccParser/main.c */ \
- yaccParser/atype.c \
- yaccParser/binding.c \
- yaccParser/coresyn.c \
- yaccParser/entidt.c \
- yaccParser/finfot.c \
- yaccParser/hpragma.c \
- yaccParser/hslexer.c \
- yaccParser/hsparser.tab.c \
- yaccParser/id.c \
- yaccParser/import_dirlist.c \
- yaccParser/infix.c \
- yaccParser/list.c \
- yaccParser/literal.c \
- yaccParser/pbinding.c \
- /* yaccParser/printtree.c */ \
- yaccParser/syntax.c \
- yaccParser/tree.c \
- yaccParser/ttype.c \
- yaccParser/type2context.c \
- yaccParser/util.c
-
-HSP_OBJS_O = /* yaccParser/main.o */ \
- yaccParser/atype.o \
- yaccParser/binding.o \
- yaccParser/coresyn.o \
- yaccParser/entidt.o \
- yaccParser/finfot.o \
- yaccParser/hpragma.o \
- yaccParser/hslexer.o \
- yaccParser/hsparser.tab.o \
- yaccParser/id.o \
- yaccParser/import_dirlist.o \
- yaccParser/infix.o \
- yaccParser/list.o \
- yaccParser/literal.o \
- yaccParser/pbinding.o \
- /* yaccParser/printtree.o */ \
- yaccParser/syntax.o \
- yaccParser/tree.o \
- yaccParser/ttype.o \
- yaccParser/type2context.o \
- yaccParser/util.o
-
-/* DPH uses some tweaked files; here are the lists again... */
-
-#if BuildDataParallelHaskell == YES
-DPH_HSP_SRCS_C = yaccParser/atype.c \
- yaccParser/binding.c \
- yaccParser/coresyn.c \
- yaccParser/entidt.c \
- yaccParser/finfot.c \
- yaccParser/hpragma.c \
- yaccParser/hslexer-DPH.c \
- yaccParser/hsparser-DPH.tab.c \
- yaccParser/id.c \
- yaccParser/import_dirlist.c \
- yaccParser/infix.c \
- yaccParser/list.c \
- yaccParser/literal.c \
- yaccParser/main.c \
- yaccParser/pbinding.c \
- yaccParser/printtree.c \
- yaccParser/syntax.c \
- yaccParser/tree-DPH.c \
- yaccParser/ttype-DPH.c \
- yaccParser/type2context.c \
- yaccParser/util.c
-
-DPH_HSP_OBJS_O = yaccParser/atype.o \
- yaccParser/binding.o \
- yaccParser/coresyn.o \
- yaccParser/entidt.o \
- yaccParser/finfot.o \
- yaccParser/hpragma.o \
- yaccParser/hslexer-DPH.o \
- yaccParser/hsparser-DPH.tab.o \
- yaccParser/id.o \
- yaccParser/import_dirlist.o \
- yaccParser/infix.o \
- yaccParser/list.o \
- yaccParser/literal.o \
- yaccParser/main.o \
- yaccParser/pbinding.o \
- yaccParser/printtree.o \
- yaccParser/syntax.o \
- yaccParser/tree-DPH.o \
- yaccParser/ttype-DPH.o \
- yaccParser/type2context.o \
- yaccParser/util.o
-#endif
+CPP_DEFINES = $(D_DEBUG)
+
+HSP_SRCS_C = parser/constr.c \
+ parser/binding.c \
+ parser/pbinding.c \
+ parser/coresyn.c \
+ parser/entidt.c \
+ parser/hpragma.c \
+ parser/hslexer.c \
+ parser/hsparser.tab.c \
+ parser/id.c \
+ parser/import_dirlist.c \
+ parser/infix.c \
+ parser/list.c \
+ parser/literal.c \
+ parser/maybe.c \
+ parser/either.c \
+ parser/qid.c \
+ parser/syntax.c \
+ parser/tree.c \
+ parser/ttype.c \
+ parser/type2context.c \
+ parser/util.c
+
+HSP_OBJS_O = parser/constr.o \
+ parser/binding.o \
+ parser/pbinding.o \
+ parser/coresyn.o \
+ parser/entidt.o \
+ parser/hpragma.o \
+ parser/hslexer.o \
+ parser/hsparser.tab.o \
+ parser/id.o \
+ parser/import_dirlist.o \
+ parser/infix.o \
+ parser/list.o \
+ parser/literal.o \
+ parser/maybe.o \
+ parser/either.o \
+ parser/qid.o \
+ parser/syntax.o \
+ parser/tree.o \
+ parser/ttype.o \
+ parser/type2context.o \
+ parser/util.o
/* this is for etags */
-REAL_HSP_SRCS_C = yaccParser/main.c \
- yaccParser/hschooks.c \
- yaccParser/hsclink.c \
- yaccParser/id.c \
- yaccParser/util.c \
- yaccParser/syntax.c \
- yaccParser/type2context.c \
- yaccParser/import_dirlist.c \
- yaccParser/infix.c \
- yaccParser/printtree.c
+REAL_HSP_SRCS_C = parser/main.c \
+ parser/hschooks.c \
+ parser/hsclink.c \
+ parser/id.c \
+ parser/util.c \
+ parser/syntax.c \
+ parser/type2context.c \
+ parser/import_dirlist.c \
+ parser/infix.c \
+ parser/printtree.c
UgenNeededHere(all depend)
NormalLibraryTarget(hsp,$(HSP_OBJS_O))
/* We need the hsp program for hstags to work! */
-BuildPgmFromCFiles(hsp,yaccParser/printtree.o yaccParser/main.o,,libhsp.a)
-#if BuildDataParallelHaskell == YES
-BuildPgmFromCFiles(dphsp,$(DPH_HSP_OBJS_O),,)
-#endif
+BuildPgmFromCFiles(hsp,parser/printtree.o parser/main.o,,libhsp.a)
#if DoInstallGHCSystem == YES
MakeDirectories(install, $(INSTLIBDIR_GHC))
InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC))
-# if BuildDataParallelHaskell == YES
-InstallBinaryTarget(dphsp,$(INSTLIBDIR_GHC))
-# endif
#endif /* DoInstall... */
-YaccRunWithExpectMsg(yaccParser/hsparser,12,2)
-
-UgenTarget(yaccParser/atype)
-UgenTarget(yaccParser/binding)
-UgenTarget(yaccParser/coresyn)
-UgenTarget(yaccParser/entidt)
-UgenTarget(yaccParser/finfot)
-UgenTarget(yaccParser/literal)
-UgenTarget(yaccParser/list)
-UgenTarget(yaccParser/pbinding)
-UgenTarget(yaccParser/hpragma)
-UgenTarget(yaccParser/tree)
-UgenTarget(yaccParser/ttype)
-
-#if BuildDataParallelHaskell == YES
-YaccRunWithExpectMsg(yaccParser/hsparser-DPH,12,4)
-UgenTarget(yaccParser/tree-DPH)
-UgenTarget(yaccParser/ttype-DPH)
-#endif
-
-UGENS_C = yaccParser/atype.c \
- yaccParser/binding.c \
- yaccParser/coresyn.c \
- yaccParser/entidt.c \
- yaccParser/finfot.c \
- yaccParser/literal.c \
- yaccParser/list.c \
- yaccParser/pbinding.c \
- yaccParser/hpragma.c \
- yaccParser/tree.c \
- yaccParser/ttype.c
-
-compile(yaccParser/UgenAll,lhs,if_ghc(-fvia-C))
-compile(yaccParser/UgenUtil,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_atype,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_binding,hs,-H20m if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_coresyn,hs,-H20m if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_entidt,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_finfot,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_hpragma,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_list,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_literal,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_pbinding,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_tree,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_treeHACK,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
-compile(yaccParser/U_ttype,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"'))
+YaccRunWithExpectMsg(parser/hsparser,16,0)
+
+UgenTarget(parser/constr)
+UgenTarget(parser/binding)
+UgenTarget(parser/pbinding)
+UgenTarget(parser/coresyn)
+UgenTarget(parser/entidt)
+UgenTarget(parser/hpragma)
+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 \
+ parser/pbinding.c \
+ parser/coresyn.c \
+ parser/entidt.c \
+ parser/literal.c \
+ parser/list.c \
+ parser/maybe.c \
+ parser/either.c \
+ parser/qid.c \
+ parser/hpragma.c \
+ parser/tree.c \
+ parser/ttype.c
+
+/* Putting the -#include"hspincl.h" option into the
+ PARSER_HS_OPTS line really does not work (it depends
+ on the 'make' that you use).
+*/
+PARSER_HS_OPTS = if_ghc(-fvia-C -I$(COMPINFO_DIR) -Iparser)
+
+compile(parser/UgenAll,lhs,if_ghc(-fvia-C))
+compile(parser/UgenUtil,lhs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_constr,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_binding,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_pbinding,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_coresyn,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_entidt,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_hpragma,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_list,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_literal,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_maybe,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_either,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_qid,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_tree,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
+compile(parser/U_ttype,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
/* finished with local macros */
#undef compile
/* *** misc *************************************************** */
-/* ?????????? ToDo: need parser depend/clean/etc in here ????? */
-
-/* omit for now:
-LitDocRootTargetWithNamedOutput(root,lit,root-standalone)
-*/
-/* LitDependTarget(root,lit): built-in to the above */
+DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS)
-/* mkdependHS has to have the -i.../-I... subdirectory lists even if "ghc" does not
-*/
#if GhcWithHscBuiltViaC == NO
-DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS)
-MKDEPENDHS_OPTS= $(DASH_I_SUBDIR_LIST) -i$(SUBDIR_LIST) -I$(MAIN_INCLUDE_DIR)
-
-#else /* booting from .hc (no ghci) */
-DEPSRCS = $(HSCSRCS_LHS) $(HSCSRCS_HS)
-MKDEPENDHS_OPTS= -o .hc $(DASH_I_SUBDIR_LIST) -i$(SUBDIR_LIST) -I$(MAIN_INCLUDE_DIR)
+MKDEPENDHS_OPTS= -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
+#else /* booting from .hc */
+MKDEPENDHS_OPTS= -o .hc -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h
#endif /* booting from .hc files */
#if HaskellCompilerType != HC_USE_HC_FILES
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AbsCFuns where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import Unique(Unique)
-data AbstractC
-data CAddrMode
-data PrimKind
-data SplitUniqSupply
-amodeCanSurviveGC :: CAddrMode -> Bool
-flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
-getAmodeKind :: CAddrMode -> PrimKind
-kindFromMagicId :: MagicId -> PrimKind
-mixedPtrLocn :: CAddrMode -> Bool
-mixedTypeLocn :: CAddrMode -> Bool
-mkAbsCStmtList :: AbstractC -> [AbstractC]
-mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
-mkAbstractCs :: [AbstractC] -> AbstractC
-mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC
-nonemptyAbsC :: AbstractC -> Labda AbstractC
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AbsCSyn where
-import AbsCFuns(amodeCanSurviveGC, flattenAbsC, getAmodeKind, kindFromMagicId, mixedPtrLocn, mixedTypeLocn, mkAbsCStmtList, mkAbsCStmts, mkAbstractCs, mkAlgAltsCSwitch, nonemptyAbsC)
-import BasicLit(BasicLit(..), mkMachInt, mkMachWord)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import ClosureInfo(ClosureInfo, LambdaFormInfo)
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset, HpRelOffset(..), SpARelOffset(..), SpBRelOffset(..), VirtualHeapOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..), addOff, fixedHdrSize, intOff, intOffsetIntoGoods, isZeroOff, maxOff, possiblyEqualHeapOffset, pprHeapOffset, subOff, totHdrSize, varHdrSize, zeroOff)
-import Id(ConTag(..), Id)
-import Maybes(Labda)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PprAbsC(dumpRealC, writeRealC)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind(..))
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Stdio(_FILE)
-import StgSyn(StgAtom, StgExpr, UpdateFlag)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-import Unpretty(Unpretty(..))
-class NamedThing a where
- getExportFlag :: a -> ExportFlag
- isLocallyDefined :: a -> Bool
- getOrigName :: a -> (_PackedString, _PackedString)
- getOccurrenceName :: a -> _PackedString
- getInformingModules :: a -> [_PackedString]
- getSrcLoc :: a -> SrcLoc
- getTheUnique :: a -> Unique
- hasType :: a -> Bool
- getType :: a -> UniType
- fromPreludeCore :: a -> Bool
-class Outputable a where
- ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data AbstractC = AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] Int | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker
-data BasicLit = MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer)
-data CAddrMode = CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool
-data CExprMacro = INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG
-data CLabel
-data CSeq
-data CStmtMacro = ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG
-data ClosureInfo
-data LambdaFormInfo
-data GlobalSwitch
-data SimplifierSwitch
-data CostCentre
-data HeapOffset
-type HpRelOffset = HeapOffset
-data MagicId = BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg
-data RegRelative = HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset
-data ReturnInfo = DirectReturn | StaticVectoredReturn Int | DynamicVectoredReturn CAddrMode
-type SpARelOffset = Int
-type SpBRelOffset = Int
-type VirtualHeapOffset = HeapOffset
-type VirtualSpAOffset = Int
-type VirtualSpBOffset = Int
-type ConTag = Int
-data Id
-data Labda a
-data ExportFlag
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
-data PrimOp
-data SMRep
-data SplitUniqSupply
-data SrcLoc
-data StgAtom a
-data StgExpr a b
-data UpdateFlag
-data TyCon
-data UniType
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-type Unpretty = CSeq
-amodeCanSurviveGC :: CAddrMode -> Bool
-flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
-getAmodeKind :: CAddrMode -> PrimKind
-kindFromMagicId :: MagicId -> PrimKind
-mixedPtrLocn :: CAddrMode -> Bool
-mixedTypeLocn :: CAddrMode -> Bool
-mkAbsCStmtList :: AbstractC -> [AbstractC]
-mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
-mkAbstractCs :: [AbstractC] -> AbstractC
-mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC
-nonemptyAbsC :: AbstractC -> Labda AbstractC
-mkMachInt :: Integer -> BasicLit
-mkMachWord :: Integer -> BasicLit
-addOff :: HeapOffset -> HeapOffset -> HeapOffset
-fixedHdrSize :: HeapOffset
-dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> [Char]
-infoptr :: MagicId
-intOff :: Int -> HeapOffset
-intOffsetIntoGoods :: HeapOffset -> Labda Int
-isVolatileReg :: MagicId -> Bool
-isZeroOff :: HeapOffset -> Bool
-maxOff :: HeapOffset -> HeapOffset -> HeapOffset
-mkCCostCentre :: CostCentre -> CAddrMode
-mkIntCLit :: Int -> CAddrMode
-node :: MagicId
-possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool
-pprHeapOffset :: PprStyle -> HeapOffset -> CSeq
-subOff :: HeapOffset -> HeapOffset -> HeapOffset
-totHdrSize :: SMRep -> HeapOffset
-varHdrSize :: SMRep -> HeapOffset
-zeroOff :: HeapOffset
-writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> _State _RealWorld -> ((), _State _RealWorld)
-instance Eq MagicId
-instance Eq BasicLit
-instance Eq CLabel
-instance Eq GlobalSwitch
-instance Eq SimplifierSwitch
-instance Eq Id
-instance Eq PrimKind
-instance Eq PrimOp
-instance Eq Unique
-instance Ord BasicLit
-instance Ord CLabel
-instance Ord GlobalSwitch
-instance Ord SimplifierSwitch
-instance Ord Id
-instance Ord PrimKind
-instance Ord Unique
-instance NamedThing Id
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable BasicLit
-instance Outputable Bool
-instance Outputable Id
-instance Outputable PrimKind
-instance Outputable PrimOp
-instance Outputable a => Outputable (StgAtom a)
-instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b)
-instance Outputable a => Outputable [a]
-instance Text CExprMacro
-instance Text CStmtMacro
-instance Text Unique
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[AbstractC]{Abstract C: the last stop before machine code}
CAddrMode(..),
ReturnInfo(..),
mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
- mkIntCLit,
+ mkIntCLit,
mkAbsCStmtList,
mkCCostCentre,
-- closure info
ClosureInfo, LambdaFormInfo, UpdateFlag, SMRep,
- -- stuff from AbsCFuns and PprAbsC...
- nonemptyAbsC, flattenAbsC, getAmodeKind,
+ -- stuff from AbsCUtils and PprAbsC...
+ nonemptyAbsC, flattenAbsC, getAmodeRep,
mixedTypeLocn, mixedPtrLocn,
-#ifdef __GLASGOW_HASKELL__
writeRealC,
-#endif
dumpRealC,
- kindFromMagicId, -- UNUSED: getDestinationRegs,
- amodeCanSurviveGC,
+ kindFromMagicId,
+ amodeCanSurviveGC
#ifdef GRAN
- CostRes(Cost),
+ , CostRes(Cost)
#endif
-- and stuff to make the interface self-sufficient
- Outputable(..), NamedThing(..),
- PrettyRep, ExportFlag, SrcLoc, Unique,
- CSeq, PprStyle, Pretty(..), Unpretty(..),
- -- blargh...
- UniType,
-
- PrimKind(..), -- re-exported NON-ABSTRACTLY
- BasicLit(..), mkMachInt, mkMachWord, -- re-exported NON-ABSTRACTLY
- Id, ConTag(..), Maybe, PrimOp, SplitUniqSupply, TyCon,
- CLabel, GlobalSwitch, CostCentre,
- SimplifierSwitch, UniqSet(..), UniqFM, StgExpr, StgAtom
) where
-import AbsCFuns -- used, and re-exported
+import AbsCUtils -- used, and re-exported
import ClosureInfo -- ditto
import Costs
import PprAbsC -- ditto
import HeapOffs hiding ( hpRelToInt )
-import AbsPrel ( PrimOp
+import PrelInfo ( PrimOp
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import CLabelInfo
-import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch )
-import BasicLit ( mkMachInt, mkMachWord, BasicLit(..) )
+import Literal ( mkMachInt, mkMachWord, Literal(..) )
+import CLabel
+import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG )
+import CostCentre -- for CostCentre type
import Id ( Id, ConTag(..), DataCon(..) )
import Maybes ( Maybe )
import Outputable
-import Unpretty -- ********** NOTE **********
-import PrimKind ( PrimKind(..) )
-import CostCentre -- for CostCentre type
-import StgSyn ( StgExpr, StgAtom, StgBinderInfo )
+import PrimRep ( PrimRep(..) )
+import StgSyn ( GenStgExpr, GenStgArg, StgBinderInfo )
import UniqSet ( UniqSet(..), UniqFM )
-import Unique ( Unique )
+import Unpretty -- ********** NOTE **********
import Util
-
-#ifndef DPH
-import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG )
-#else
-import CgCompInfo ( spARelToInt, spBRelToInt )
-import DapInfo ( virtualHeapOffsetToInt )
-#endif {- Data Parallel Haskell -}
\end{code}
@AbstractC@ is a list of Abstract~C statements, but the data structure
is the type of the lhs. However, when the lhs is a pointer to mixed
types (e.g. SpB relative), the type of the assignment is the type of
the rhs for float types, or the generic StgWord for all other types.
-(In particular, a CharKind on the rhs is promoted to IntKind when
+(In particular, a CharRep on the rhs is promoted to IntRep when
stored in a mixed type location.)
\begin{code}
| CJump
CAddrMode -- Put this in the program counter
- -- eg `CJump (CReg (VanillaReg PtrKind 1))' puts Ret1 in PC
+ -- eg `CJump (CReg (VanillaReg PtrRep 1))' puts Ret1 in PC
-- Enter can be done by:
-- CJump (CVal NodeRel zeroOff)
ReturnInfo -- How to get the return address from the base address
| CSwitch CAddrMode
- [(BasicLit, AbstractC)] -- alternatives
+ [(Literal, AbstractC)] -- alternatives
AbstractC -- default; if there is no real Abstract C in here
-- (e.g., all comments; see function "nonemptyAbsC"),
-- then that means the default _cannot_ occur.
-- INVARIANT: When a PrimOp which can cause GC is used, the
-- only live data is tidily on the STG stacks or in the STG
-- registers (the code generator ensures this).
- --
+ --
-- Why this? Because if the arguments were arbitrary
-- addressing modes, they might be things like (Hp+6) which
-- will get utterly spongled by GC.
- | CSimultaneous -- Perform simultaneously all the statements
+ | CSimultaneous -- Perform simultaneously all the statements
AbstractC -- in the nested AbstractC. They are only
-- allowed to be CAssigns, COpStmts and AbsCNops, so the
-- "simultaneous" part just concerns making
| CStaticClosure
CLabel -- The (full, not base) label to use for labelling the closure.
- ClosureInfo
- CAddrMode -- cost centre identifier to place in closure
+ ClosureInfo
+ CAddrMode -- cost centre identifier to place in closure
[CAddrMode] -- free vars; ptrs, then non-ptrs
-- False <=> extern; just say so
CostCentre
-{-UNUSED:
- | CComment -- to insert a comment into the output
- FAST_STRING
--}
-
| CClosureUpdInfo
AbstractC -- InRegs Info Table (CClosureInfoTable)
-- ^^^^^^^^^^^^^^^^^
-- out of date -- HWL
| CSplitMarker -- Split into separate object modules here
-
-#ifdef DPH
- | CNativeInfoTableAndCode
- ClosureInfo -- Explains placement and layout of closure
- String -- closure description
- AbstractC -- We want to apply the trick outlined in the STG
- -- paper of putting the info table before the normal
- -- entry point to a function (well a very similar
- -- trick, see nativeDap/NOTES.static). By putting the
- -- abstractC here we stop the info table
- -- wandering off :-) (No post mangler hacking going
- -- on here Will :-)
-#endif {- Data Parallel Haskell -}
\end{code}
About @CMacroStmt@, etc.: notionally, they all just call some
| UPD_BH_SINGLE_ENTRY
| PUSH_STD_UPD_FRAME
| POP_STD_UPD_FRAME
---UNUSED: | PUSH_CON_UPD_FRAME
| SET_ARITY
| CHK_ARITY
| SET_TAG
#ifdef GRAN
- | GRAN_FETCH -- for GrAnSim only -- HWL
- | GRAN_RESCHEDULE -- for GrAnSim only -- HWL
- | GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL
- | THREAD_CONTEXT_SWITCH -- for GrAnSim only -- HWL
+ | GRAN_FETCH -- for GrAnSim only -- HWL
+ | GRAN_RESCHEDULE -- for GrAnSim only -- HWL
+ | GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL
+ | THREAD_CONTEXT_SWITCH -- for GrAnSim only -- HWL
#endif
- deriving Text
+ deriving Text
\end{code}
Addressing modes: these have @PrimitiveKinds@ pinned on them.
\begin{code}
data CAddrMode
- = CVal RegRelative PrimKind
+ = CVal RegRelative PrimRep
-- On RHS of assign: Contents of Magic[n]
-- On LHS of assign: location Magic[n]
-- (ie at addr Magic+n)
| CTableEntry -- CVal should be generalized to allow this
CAddrMode -- Base
CAddrMode -- Offset
- PrimKind -- For casting
+ PrimRep -- For casting
- | CTemp Unique PrimKind -- Temporary locations
+ | CTemp Unique PrimRep -- Temporary locations
-- ``Temporaries'' correspond to local variables in C, and registers in
-- native code.
- -- OLD: The kind (that used to be there) is redundant, but it's REALLY helpful for
- -- generating C declarations
| CLbl CLabel -- Labels in the runtime system, etc.
-- See comment under CLabelledData about (String,Name)
- PrimKind -- the kind is so we can generate accurate C decls
+ PrimRep -- the kind is so we can generate accurate C decls
| CUnVecLbl -- A choice of labels left up to the back end
CLabel -- direct
CLabel -- vectored
- | CCharLike CAddrMode -- The address of a static char-like closure for
+ | CCharLike CAddrMode -- The address of a static char-like closure for
-- the specified character. It is guaranteed to be in
-- the range 0..255.
-- range mIN_INTLIKE..mAX_INTLIKE
| CString FAST_STRING -- The address of the null-terminated string
- | CLit BasicLit
+ | CLit Literal
| CLitLit FAST_STRING -- completely literal literal: just spit this String
-- into the C output
- PrimKind
+ PrimRep
| COffset HeapOffset -- A literal constant, not an offset *from* anything!
-- ToDo: this should really be CLitOffset
-- then the code for this thing will be entered
| CMacroExpr
- PrimKind -- the kind of the result
+ PrimRep -- the kind of the result
CExprMacro -- the macro to generate a value
- [CAddrMode] -- and its arguments
+ [CAddrMode] -- and its arguments
| CCostCentre -- If Bool is True ==> it to be printed as a String,
CostCentre -- (*not* as a C identifier or some such).
-- Argument and return registers
| VanillaReg -- pointers, unboxed ints and chars
- PrimKind -- PtrKind, IntKind, CharKind, StablePtrKind or MallocPtrKind
+ PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or MallocPtrRep
-- (in case we need to distinguish)
FAST_INT -- its number (1 .. mAX_Vanilla_REG)
| LivenessReg -- (parallel only) used when we need to record explicitly
-- what registers are live
- | ActivityReg -- mentioned only in nativeGen (UNUSED)
| StdUpdRetVecReg -- mentioned only in nativeGen
| StkStubReg -- register holding STK_STUB_closure (for stubbing dead stack slots)
| VoidReg -- see "VoidPrim" type; just a placeholder; no actual register
-#ifdef DPH
--- In DPH we use:
--- (VanillaReg X) for pointers, ints, chars floats
--- (DataReg X) for ints chars or floats
--- (DoubleReg X) first 32 bits of double in register X, second 32 in
--- register X+1; DoubleReg is a synonymn for
--- DataReg X; DataReg X+1
-
- | DataReg
- PrimKind
- Int
-#endif {- Data Parallel Haskell -}
-
-node = VanillaReg PtrKind ILIT(1) -- A convenient alias for Node
-infoptr = VanillaReg DataPtrKind ILIT(2) -- An alias for InfoPtr
+node = VanillaReg PtrRep ILIT(1) -- A convenient alias for Node
+infoptr = VanillaReg DataPtrRep ILIT(2) -- An alias for InfoPtr
\end{code}
We need magical @Eq@ because @VanillaReg@s come in multiple flavors.
\begin{code}
instance Eq MagicId where
-#ifdef DPH
- (FloatReg f1) == (FloatReg f2) = f1 == f2
- (DoubleReg d1) == (DoubleReg d2) = d1 == d2
- (DataReg _ d1) == (DataReg _ d2) = d1 == d2
-#endif {- Data Parallel Haskell -}
- reg1 == reg2 = tagOf_MagicId reg1 _EQ_ tagOf_MagicId reg2
+ reg1 == reg2 = tagOf_MagicId reg1 _EQ_ tagOf_MagicId reg2
tagOf_MagicId BaseReg = (ILIT(0) :: FAST_INT)
tagOf_MagicId StkOReg = ILIT(1)
tagOf_MagicId Hp = ILIT(8)
tagOf_MagicId HpLim = ILIT(9)
tagOf_MagicId LivenessReg = ILIT(10)
---tagOf_MagicId ActivityReg = ILIT(11) -- UNUSED
tagOf_MagicId StdUpdRetVecReg = ILIT(12)
tagOf_MagicId StkStubReg = ILIT(13)
tagOf_MagicId CurCostCentre = ILIT(14)
tagOf_MagicId (VanillaReg _ i) = ILIT(15) _ADD_ i
-#ifndef DPH
tagOf_MagicId (FloatReg i) = ILIT(15) _ADD_ maxv _ADD_ i
where
maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
where
maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
maxf = case mAX_Float_REG of { IBOX(x) -> x }
-
-#else
-tagOf_MagicId (DoubleReg i) = ILIT(1066) _ADD_ i -- Hacky, but we want disjoint
-tagOf_MagicId (DataReg _ IBOX(i)) = ILIT(1066) _ADD_ i -- range with Vanillas
-#endif {- Data Parallel Haskell -}
\end{code}
Returns True for any register that {\em potentially} dies across
\begin{code}
isVolatileReg :: MagicId -> Bool
-isVolatileReg any = True
+isVolatileReg any = True
--isVolatileReg (FloatReg _) = True
--isVolatileReg (DoubleReg _) = True
\end{code}
%************************************************************************
It's in \tr{PprAbsC.lhs}.
-
-%************************************************************************
-%* *
-\subsection[EqInstances]{Eq instance for RegRelative & CAddrMode}
-%* *
-%************************************************************************
-
-DPH requires CAddrMode to be in class Eq for its register allocation
-algorithm. The code for equality is rather conservative --- it doesnt
-matter if two things are determined to be not equal (even if they really are,
-i.e with CVal's), we just generate less efficient code.
-
-NOTE(07/04/93) It does matter, its doing really bad with the reg relative
- stuff.
-
-\begin{code}
-#ifdef DPH
-instance Eq CAddrMode where
- (CVal r _) == (CVal r' _) = r `eqRRel` r'
- (CAddr r) == (CAddr r') = r `eqRRel` r'
- (CReg reg) == (CReg reg') = reg == reg'
- (CTemp u _) == (CTemp u' _) = u == u'
- (CLbl l _) == (CLbl l' _) = l == l'
- (CUnVecLbl d v) == (CUnVecLbl d' v') = d == d' && v == v'
- (CCharLike c) == (CCharLike c') = c == c'
- (CIntLike c) == (CIntLike c') = c == c'
- (CString str) == (CString str') = str == str'
- (CLit lit) == (CLit lit') = lit == lit'
- (COffset off) == (COffset off') = possiblyEqualHeapOffset off off'
- (CCode _) == (CCode _) = panic "(==) Code in CAddrMode"
- (CLabelledCode _ _) == (CLabelledCode _ _)= panic "(==) LabCode in CAddrMode"
- _ == _ = False
-
-
-eqRRel :: RegRelative -> RegRelative -> Bool
-eqRRel (NodeRel x) (NodeRel y)
- = virtualHeapOffsetToInt x == virtualHeapOffsetToInt y
-
-eqRRel l@(SpARel _ _) r@(SpARel _ _)
- = spARelToInt l == spARelToInt r
-
-eqRRel l@(SpBRel _ _) r@(SpBRel _ _)
- = spBRelToInt l == spBRelToInt r
-
-eqRRel (HpRel hp off) (HpRel hp' off')
- = (virtualHeapOffsetToInt (hp `subOff` off)) ==
- (virtualHeapOffsetToInt (hp' `subOff` off'))
-
-eqRRel _ _ = False
-
-eqRetInfo:: ReturnInfo -> ReturnInfo -> Bool
-eqRetInfo DirectReturn DirectReturn = True
-eqRetInfo (StaticVectoredReturn x) (StaticVectoredReturn x') = x == x'
-eqRetInfo _ _ = False
-#endif {- Data Parallel Haskell -}
-\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
-\section[AbsCFuns]{Help functions for Abstract~C datatype}
+\section[AbsCUtils]{Help functions for Abstract~C datatype}
\begin{code}
#include "HsVersions.h"
-module AbsCFuns (
+module AbsCUtils (
nonemptyAbsC,
mkAbstractCs, mkAbsCStmts,
mkAlgAltsCSwitch,
kindFromMagicId,
- getAmodeKind, amodeCanSurviveGC,
+ getAmodeRep, amodeCanSurviveGC,
mixedTypeLocn, mixedPtrLocn,
flattenAbsC,
---UNUSED: getDestinationRegs,
- mkAbsCStmtList,
+ mkAbsCStmtList
-- printing/forcing stuff comes from PprAbsC
-- and for interface self-sufficiency...
- AbstractC, CAddrMode, PrimKind, SplitUniqSupply
) where
import AbsCSyn
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( kindFromType, splitTyArgs, TauType(..),
- TyVar, TyCon, Arity(..), Class, UniType
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-
-#ifndef DPH
-import CLabelInfo ( CLabel, mkReturnPtLabel, mkVecTblLabel )
-#else
-import CLabelInfo ( CLabel, mkReturnPtLabel,
- isNestableBlockLabel, isSlowFastLabelPair )
-#endif {- Data Parallel Haskell -}
-
-import BasicLit ( kindOfBasicLit )
+import Literal ( literalPrimRep )
+import CLabel ( CLabel, mkReturnPtLabel, mkVecTblLabel )
import Digraph ( stronglyConnComp )
import Id ( fIRST_TAG, ConTag(..), DataCon(..), Id )
import Maybes ( Maybe(..) )
-import PrimKind ( getKindSize, retKindSize, PrimKind(..) )
-import SplitUniq
-import StgSyn ( StgAtom )
-import Unique -- UniqueSupply primitives used in flattening monad
-import Util
+import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) )
+import UniqSupply
+import StgSyn ( GenStgArg )
infixr 9 `thenFlt`
\end{code}
\begin{code}
nonemptyAbsC :: AbstractC -> Maybe AbstractC
nonemptyAbsC AbsCNop = Nothing
---UNUSED:nonemptyAbsC (CComment _) = Nothing
nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
Nothing -> nonemptyAbsC s2
Just x -> Just (AbsCStmts x s2)
Get the sho' 'nuff statements out of an @AbstractC@.
\begin{code}
-{-
mkAbsCStmtList :: AbstractC -> [AbstractC]
-mkAbsCStmtList AbsCNop = []
---UNUSED:mkAbsCStmtList (CComment _) = []
-mkAbsCStmtList (AbsCStmts s1 s2) = mkAbsCStmtList s1 ++ mkAbsCStmtList s2
-mkAbsCStmtList s@(CSimultaneous c) = if null (mkAbsCStmtList c)
- then []
- else [s]
-mkAbsCStmtList other = [other]
--}
+mkAbsCStmtList absC = mkAbsCStmtList' absC []
-mkAbsCStmtList :: AbstractC -> [AbstractC]
-mkAbsCStmtList absC = mkAbsCStmtList' absC []
-
-- Optimised a la foldr/build!
-mkAbsCStmtList' AbsCNop r = r
---UNUSED:mkAbsCStmtList' (CComment _) r = r
-mkAbsCStmtList' (AbsCStmts s1 s2) r =
- mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
-mkAbsCStmtList' s@(CSimultaneous c) r =
- if null (mkAbsCStmtList c) then r else s : r
-mkAbsCStmtList' other r = other : r
+mkAbsCStmtList' AbsCNop r = r
+
+mkAbsCStmtList' (AbsCStmts s1 s2) r
+ = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
+
+mkAbsCStmtList' s@(CSimultaneous c) r
+ = if null (mkAbsCStmtList c) then r else s : r
+mkAbsCStmtList' other r = other : r
\end{code}
\begin{code}
-- data types. Why? Because for two-constructor types, zero is faster
-- to create and distinguish from 1 than are 1 and 2.
- -- We also need to convert to BasicLits to keep the CSwitch happy
+ -- We also need to convert to Literals to keep the CSwitch happy
adjust tagged_alts
= [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
| (tag, abs_c) <- tagged_alts ]
%************************************************************************
%* *
-\subsubsection[AbsCFuns-kinds-from-MagicIds]{Kinds from MagicIds}
+\subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
%* *
%************************************************************************
\begin{code}
-kindFromMagicId BaseReg = PtrKind
-kindFromMagicId StkOReg = PtrKind
+kindFromMagicId BaseReg = PtrRep
+kindFromMagicId StkOReg = PtrRep
kindFromMagicId (VanillaReg kind _) = kind
-kindFromMagicId (FloatReg _) = FloatKind
-kindFromMagicId (DoubleReg _) = DoubleKind
-kindFromMagicId TagReg = IntKind
-kindFromMagicId RetReg = RetKind
-kindFromMagicId SpA = PtrKind
-kindFromMagicId SuA = PtrKind
-kindFromMagicId SpB = PtrKind
-kindFromMagicId SuB = PtrKind
-kindFromMagicId Hp = PtrKind
-kindFromMagicId HpLim = PtrKind
-kindFromMagicId LivenessReg = IntKind
---kindFromMagicId ActivityReg = IntKind -- UNUSED
-kindFromMagicId StdUpdRetVecReg = PtrKind
-kindFromMagicId StkStubReg = PtrKind
-kindFromMagicId CurCostCentre = CostCentreKind
-kindFromMagicId VoidReg = VoidKind
-#ifdef DPH
-kindFromMagicId (DataReg _ n) = kind
-#endif {- Data Parallel Haskell -}
+kindFromMagicId (FloatReg _) = FloatRep
+kindFromMagicId (DoubleReg _) = DoubleRep
+kindFromMagicId TagReg = IntRep
+kindFromMagicId RetReg = RetRep
+kindFromMagicId SpA = PtrRep
+kindFromMagicId SuA = PtrRep
+kindFromMagicId SpB = PtrRep
+kindFromMagicId SuB = PtrRep
+kindFromMagicId Hp = PtrRep
+kindFromMagicId HpLim = PtrRep
+kindFromMagicId LivenessReg = IntRep
+kindFromMagicId StdUpdRetVecReg = PtrRep
+kindFromMagicId StkStubReg = PtrRep
+kindFromMagicId CurCostCentre = CostCentreRep
+kindFromMagicId VoidReg = VoidRep
\end{code}
%************************************************************************
%* *
-\subsection[AbsCFuns-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
+\subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
%* *
%************************************************************************
ToDo: tiny tweaking may be in order
\begin{code}
-getAmodeKind :: CAddrMode -> PrimKind
-
-getAmodeKind (CVal _ kind) = kind
-getAmodeKind (CAddr _) = PtrKind
-getAmodeKind (CReg magic_id) = kindFromMagicId magic_id
-getAmodeKind (CTemp uniq kind) = kind
-getAmodeKind (CLbl label kind) = kind
-getAmodeKind (CUnVecLbl _ _) = PtrKind
-getAmodeKind (CCharLike _) = PtrKind
-getAmodeKind (CIntLike _) = PtrKind
-getAmodeKind (CString _) = PtrKind
-getAmodeKind (CLit lit) = kindOfBasicLit lit
-getAmodeKind (CLitLit _ kind) = kind
-getAmodeKind (COffset _) = IntKind
-getAmodeKind (CCode abs_C) = CodePtrKind
-getAmodeKind (CLabelledCode label abs_C) = CodePtrKind
-getAmodeKind (CJoinPoint _ _) = panic "getAmodeKind:CJoinPoint"
-getAmodeKind (CTableEntry _ _ kind) = kind
-getAmodeKind (CMacroExpr kind _ _) = kind
-getAmodeKind (CCostCentre _ _) = panic "getAmodeKind:CCostCentre"
+getAmodeRep :: CAddrMode -> PrimRep
+
+getAmodeRep (CVal _ kind) = kind
+getAmodeRep (CAddr _) = PtrRep
+getAmodeRep (CReg magic_id) = kindFromMagicId magic_id
+getAmodeRep (CTemp uniq kind) = kind
+getAmodeRep (CLbl label kind) = kind
+getAmodeRep (CUnVecLbl _ _) = PtrRep
+getAmodeRep (CCharLike _) = PtrRep
+getAmodeRep (CIntLike _) = PtrRep
+getAmodeRep (CString _) = PtrRep
+getAmodeRep (CLit lit) = literalPrimRep lit
+getAmodeRep (CLitLit _ kind) = kind
+getAmodeRep (COffset _) = IntRep
+getAmodeRep (CCode abs_C) = CodePtrRep
+getAmodeRep (CLabelledCode label abs_C) = CodePtrRep
+getAmodeRep (CTableEntry _ _ kind) = kind
+getAmodeRep (CMacroExpr kind _ _) = kind
+#ifdef DEBUG
+getAmodeRep (CJoinPoint _ _) = panic "getAmodeRep:CJoinPoint"
+getAmodeRep (CCostCentre _ _) = panic "getAmodeRep:CCostCentre"
+#endif
\end{code}
@amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
%************************************************************************
%* *
-\subsection[AbsCFuns-flattening]{Flatten Abstract~C}
+\subsection[AbsCUtils-flattening]{Flatten Abstract~C}
%* *
%************************************************************************
nesting, and flattens it into one long @AbsCStmtList@. Mainly,
@CClosureInfos@ and code for switches are pulled out to the top level.
-The various functions herein tend to produce
+The various functions herein tend to produce
\begin{enumerate}
\item
-A {\em flattened} \tr{<something>} of interest for ``here'', and
+A {\em flattened} \tr{<something>} of interest for ``here'', and
\item
Some {\em unflattened} Abstract~C statements to be carried up to the
top-level. The only real reason (now) that it is unflattened is
flattened, the ``tops'' stuff is a @CCodeBlock@.
\begin{code}
-flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
+flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
flattenAbsC us abs_C
= case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
\begin{code}
type FlatM result
= CLabel
- -> SplitUniqSupply
+ -> UniqSupply
-> result
-initFlt :: SplitUniqSupply -> FlatM a -> a
+initFlt :: UniqSupply -> FlatM a -> a
initFlt init_us m = m (panic "initFlt:CLabel") init_us
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenFlt #-}
{-# INLINE returnFlt #-}
-#endif
thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
returnFlt (r1:rs1, r2:rs2)
getUniqFlt :: FlatM Unique
-getUniqFlt label us = getSUnique us
+getUniqFlt label us = getUnique us
getUniqsFlt :: Int -> FlatM [Unique]
-getUniqsFlt i label us = getSUniques i us
+getUniqsFlt i label us = getUniques i us
setLabelFlt :: CLabel -> FlatM a -> FlatM a
setLabelFlt new_label cont label us = cont new_label us
flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
= flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) ->
- returnFlt (AbsCNop, tops `mkAbsCStmts`
- CStaticClosure closure_lbl closure_info new_cc new_amodes)
+ returnFlt (AbsCNop, tops `mkAbsCStmts`
+ CStaticClosure closure_lbl closure_info new_cc new_amodes)
flatAbsC (CRetVector tbl_label stuff deflt)
= do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) ->
mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) ->
- returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
- mkAbstractCs alt_tops,
+ returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
+ mkAbstractCs alt_tops,
CFlatRetVector tbl_label alt_amodes])
where
do_deflt deflt = case nonemptyAbsC deflt of
Nothing -> returnFlt (bogus_default_label, AbsCNop)
- Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
+ Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
-- CJump (CLabelledCode ...) case
do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
= flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
returnFlt (CCallProfCCMacro str amodes_here, tops)
---UNUSED:flatAbsC comment_stmt@(CComment comment) = returnFlt (AbsCNop, AbsCNop)
-
flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
-
-#ifdef DPH
- -- Hack since 0.16 because Direct entry code blocks can be nested
- -- within other Direct entry blocks...
- flatAbsC (CNativeInfoTableAndCode cinfo descr
- (CCodeBlock slow_label
- (AbsCStmts slow_abs_c
- (CCodeBlock fast_label fast_abs_c))))
- | isSlowFastLabelPair slow_label fast_label
- = flatAbsC slow_abs_c `thenFlt` \ (slow_here, slow_top) ->
- flatAbsC fast_abs_c `thenFlt` \ (fast_here, fast_top) ->
- returnFlt (CNativeInfoTableAndCode cinfo descr
- (CCodeBlock slow_label
- (AbsCStmts slow_here
- (CCodeBlock fast_label fast_here))),
- mkAbsCStmts slow_top fast_top)
-
- flatAbsC (CNativeInfoTableAndCode cinfo descr abs_C)
- = flatAbsC abs_C `thenFlt` \ (heres, tops) ->
- returnFlt (CNativeInfoTableAndCode cinfo descr heres, tops)
-#endif {- Data Parallel Haskell -}
-
---flatAbsC stmt = panic ("flatAbsC: funny statement " ++ printRealC (\x->False) stmt)
\end{code}
%************************************************************************
flatAmode (CLabelledCode label abs_C)
-- Push the code (with this label) to the top level
= flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
- returnFlt (CLbl label CodePtrKind,
+ returnFlt (CLbl label CodePtrRep,
tops `mkAbsCStmts` CCodeBlock label body_code)
flatAmode (CCode abs_C)
[CJump amode] -> flatAmode amode -- Elide redundant labels
_ ->
-- de-anonymous-ise the code and push it (labelled) to the top level
- getUniqFlt `thenFlt` \ new_uniq ->
+ getUniqFlt `thenFlt` \ new_uniq ->
BIND (mkReturnPtLabel new_uniq) _TO_ return_pt_label ->
flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
returnFlt (
- CLbl return_pt_label CodePtrKind,
+ CLbl return_pt_label CodePtrRep,
tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
-- DO NOT TOUCH the stuff sent to the top...
)
BEND
-
+
flatAmode (CTableEntry base index kind)
= flatAmode base `thenFlt` \ (base_amode, base_tops) ->
flatAmode index `thenFlt` \ (ix_amode, ix_tops) ->
We use the strongly-connected component algorithm, in which
* the vertices are the statements
- * an edge goes from s1 to s2 iff
+ * an edge goes from s1 to s2 iff
s1 assigns to something s2 uses
that is, if s1 should *follow* s2 in the final order
go_via_temps (CAssign dest src)
= getUniqFlt `thenFlt` \ uniq ->
- let the_temp = CTemp uniq (getAmodeKind dest) in
+ let
+ the_temp = CTemp uniq (getAmodeRep dest)
+ in
returnFlt (CAssign the_temp src, CAssign dest the_temp)
go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
= getUniqsFlt (length dests) `thenFlt` \ uniqs ->
- let the_temps = zipWith (\ u d -> CTemp u (getAmodeKind d)) uniqs dests
+ let
+ the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
in
returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
mkAbstractCs (zipWith CAssign dests the_temps))
(CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
(CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
(CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
- = rrConflictsWithRR (getKindSize k1) (getKindSize k2) reg_rel1 reg_rel2
+ = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
other1 `conflictsWith` other2 = False
-- CAddr and literals are impossible on the LHS of an assignment
rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
where
- rr (SpARel p1 o1) (SpARel p2 o2)
+ rr (SpARel p1 o1) (SpARel p2 o2)
| s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
| s1 == 1 && s2 == 1 = b1 == b2
| otherwise = (b1+s1) >= b2 &&
rr other1 other2 = False
\end{code}
-
-%************************************************************************
-%* *
-\subsection[gaze-into-simultaneous]{Registers live in a @CSimultaneous@?}
-%* *
-%************************************************************************
-
-Hidden in a blob of ``simultaneous assignments'' is the info of how
-many pointer (``followable'') registers are live (i.e., assigned
-into). What we do here is merely fish out the destination registers.
-
-\begin{code}
-{- UNUSED:
-getDestinationRegs :: AbstractC -> [MagicId]
-
-getDestinationRegs abs_c
- = foldr gather [{-acc-}] (en_list abs_c)
- where
- gather :: AbstractC -> [MagicId] -> [MagicId]
-
- -- only CAssigns and COpStmts now possible...
-
- gather (CAssign (CReg magic_id) _) acc | magic_id `not_elem` acc
- = magic_id : acc
- where
- not_elem = isn'tIn "getDestinationRegs"
-
- gather (COpStmt dests _ _ _ _) acc
- = foldr gather2 acc dests
- where
- gather2 (CReg magic_id) acc | magic_id `not_elem` acc = magic_id : acc
- gather2 _ acc = acc
-
- not_elem = isn'tIn "getDestinationRegs2"
-
- gather _ acc = acc
--}
-\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[CLabelInfo]{@CLabelInfo@: Information to make C Labels}
+\section[CLabel]{@CLabel@: Information to make C Labels}
\begin{code}
#include "HsVersions.h"
-module CLabelInfo (
+module CLabel (
CLabel, -- abstract type
mkClosureLabel,
mkVapEntryLabel,
mkVapInfoTableLabel,
---UNUSED: mkConUpdCodePtrUnvecLabel,
mkConUpdCodePtrVecLabel,
mkStdUpdCodePtrVecLabel,
mkErrorStdEntryLabel,
mkBlackHoleInfoTableLabel,
---UNUSED: mkSelectorInfoTableLabel,
---UNUSED: mkSelectorEntryLabel,
-
-#ifdef DPH
- mkLocalLabel, isLocalLabel, isNestableBlockLabel,
- isGlobalDataLabel, isDataLabel,
- needsApalDecl, isVectorTableLabel, isSlowFastLabelPair,
-#endif {- Data Parallel Haskell -}
needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
- cSEP, identToC, modnameToC, stringToC, charToC, charToEasyHaskell,
- pprCLabel,
+ pprCLabel
#ifdef GRAN
- isSlowEntryCCodeBlock,
+ , isSlowEntryCCodeBlock
#endif
-- and to make the interface self-sufficient...
- Id, TyCon, Unique
) where
-import AbsUniType ( showTyCon, cmpTyCon, isBigTupleTyCon,
- TyCon, Unique
- )
+import Ubiq{-uitous-}
+
import Id ( externallyVisibleId, cmpId_withSpecDataCon,
- isDataCon, isDictFunId, isConstMethodId_maybe,
- isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
- Id, Class, ClassOp, DataCon(..), ConTag(..), fIRST_TAG
-#ifdef DPH
- ,isInventedTopLevId
-#endif {- Data Parallel Haskell -}
+ isDataCon, isDictFunId,
+ isConstMethodId_maybe, isClassOpId,
+ isDefaultMethodId_maybe,
+ isSuperDictSelId_maybe, fIRST_TAG,
+ DataCon(..), ConTag(..), Id
)
-import Maybes
+import Maybes ( maybeToBool )
+import Unpretty -- NOTE!! ********************
+{-
import Outputable
import Pretty ( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt,
ppInteger, ppBeside, ppIntersperse, prettyToUn
#ifdef USE_ATTACK_PRAGMAS
import CharSeq
#endif
-import Unpretty -- NOTE!! ********************
-import Unique ( cmpUnique, showUnique, pprUnique, Unique )
+import Unique ( pprUnique, showUnique, Unique )
import Util
-#ifdef DPH
-import AbsCSyn ( MagicId )
-import PprAbsC ( pprMagicId )
-#endif {- Data Parallel Haskell -}
-
--- Sigh... Shouldn't this file (CLabelInfo) live in codeGen?
+-- Sigh... Shouldn't this file (CLabel) live in codeGen?
import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
-
+-}
\end{code}
things we want to find out:
\begin{code}
data CLabel
- = IdLabel -- A family of labels related to the
+ = IdLabel -- A family of labels related to the
CLabelId -- definition of a particular Id
IdLabelInfo -- Includes DataCon
| RtsLabel RtsLabelInfo
-#ifdef DPH
- | ALocalLabel Unique -- Label within a code block.
- String
-#endif {- Data Parallel Haskell -}
deriving (Eq, Ord)
\end{code}
of { LT_ -> False; EQ_ -> True; GT__ -> True }
CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b
of { LT_ -> False; EQ_ -> False; GT__ -> True }
-#ifdef __GLASGOW_HASKELL__
_tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
\end{code}
\begin{code}
data TyConLabelInfo
= UnvecConUpdCode -- Update code for the data type if it's unvectored
-
+
| VecConUpdCode ConTag -- One for each constructor which returns in
-- regs; this code actually performs an update
-
+
| StdUpdCode ConTag -- Update code for all constructors which return
-- in heap. There are a small number of variants,
-- so that the update code returns (vectored/n or
-- unvectored) in the right way.
-- ToDo: maybe replace TyCon/Int with return conv.
-
+
| InfoTblVecTbl -- For tables of info tables
-
+
| StdUpdVecTbl -- Labels the update code, or table of update codes,
-- for a particular type.
deriving (Eq, Ord)
-data CaseLabelInfo
+data CaseLabelInfo
= CaseReturnPt
| CaseVecTbl
| CaseAlt ConTag
mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
---UNUSED:mkConUpdCodePtrUnvecLabel tycon = TyConLabel tycon UnvecConUpdCode
mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl
---UNUSED:mkSelectorInfoTableLabel upd_reqd offset = RtsLabel (RtsSelectorInfoTbl upd_reqd offset)
---UNUSED: mkSelectorEntryLabel upd_reqd offset = RtsLabel (RtsSelectorEntry upd_reqd offset)
-
-#ifdef DPH
-mkLocalLabel = ALocalLabel
-#endif {- Data Parallel Haskell -}
\end{code}
\begin{code}
@needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish
object. {\em Also:} No need to spit out labels for things generated
-by the flattener (in @AbsCFuns@)---it is careful to ensure references
+by the flattener (in @AbsCUtils@)---it is careful to ensure references
to them are always backwards. These are return-point and vector-table
labels.
Declarations for (non-prelude) @Id@-based things are needed because of
mutual recursion.
\begin{code}
-needsCDecl (IdLabel _ _) = True -- OLD: not (fromPreludeCore id)
+needsCDecl (IdLabel _ _) = True
needsCDecl (CaseLabel _ _) = False
needsCDecl (TyConLabel _ (StdUpdCode _)) = False
needsCDecl (AsmTempLabel _) = False
needsCDecl (RtsLabel _) = False
-#ifdef DPH
-needsCDecl (ALocalLabel _ _) = panic "needsCDecl: Shouldn't call"
-#endif {- Data Parallel Haskell -}
-
needsCDecl other = True
\end{code}
isReadOnly (CaseLabel _ _) = True
isReadOnly (AsmTempLabel _) = True
isReadOnly (RtsLabel _) = True
-
-#ifdef DPH
-isReadOnly (ALocalLabel _ _) = panic "isReadOnly: Shouldn't call"
-#endif {- Data Parallel Haskell -}
\end{code}
Whether the label is an assembler temporary:
externallyVisibleCLabel (CaseLabel _ _) = False
externallyVisibleCLabel (AsmTempLabel _) = False
externallyVisibleCLabel (RtsLabel _) = True
-
-#ifndef DPH
-
externallyVisibleCLabel (IdLabel (CLabelId id) _)
| isDataCon id = True
| is_ConstMethodId id = True -- These are here to ensure splitting works
is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id)
is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id)
-#else
--- DPH pays a big price for exported identifiers. For example with
--- a statically allocated closure, if it is local to a file it will
--- only take up 1 word of storage; exported closures have to go
--- in a data section of their own, which gets padded out to a plane size---
--- on the DAP510 this is 32 words, DAP610 128 words, DAP710 512 words :-(
--- NOTE:16/07/93 Used isInvented (these worker things are globally visible).
--- Local labels (i.e ones within a code block) are not visible outside
--- a file.
-
-externallyVisibleCLabel (IdLabel (CLabelId id) _) = isInventedTopLevId id || isExported id
-externallyVisibleCLabel (ALocalLabel _ _) = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-@isLocalLabel@ determines if a label is local to a block---a different
-machine code jump is generated.
-
-Note(hack after 0.16): Blocks with direct entry points can appear
- within blocks labelled with a direct entry
- point --- something todo with let-no-escape.
- Fast entry blocks arent nestable, however we
- special case fall through.
-\begin{code}
-#ifdef DPH
-isLocalLabel::CLabel -> Bool
-isLocalLabel (ALocalLabel _ _) = True
-isLocalLabel _ = False
-
-isNestableBlockLabel (ALocalLabel _ _) = True
-isNestableBlockLabel (IdLabel _ EntryStd) = True
-isNestableBlockLabel (IdLabel _ ConEntry) = True
-isNestableBlockLabel (IdLabel _ StaticConEntry) = True
-isNestableBlockLabel _ = False
-
-isSlowFastLabelPair :: CLabel -> CLabel -> Bool
-isSlowFastLabelPair (IdLabel clid EntryStd) (IdLabel clid' (EntryFast _)) = clid == clid'
-isSlowFastLabelPair _ _ = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-We need to determine if a label represents a code entity, an ordinary
-data entity, or a special global data entity (placed at an absolute
-address by the runtime system that ensures fast loading of variable
-contents---global ``registers'' such as SuA are placed here as well)
-(different instructions are used in the DAP machine code).
-\begin{code}
-#ifdef DPH
-isGlobalDataLabel _ = False
-
-isDataLabel :: CLabel -> Bool
-isDataLabel (IdLabel _ Closure) = True
-isDataLabel _ = False
-
-isVectorTableLabel :: CLabel -> Bool
-isVectorTableLabel (VecTblCLabel _) = True
-isVectorTableLabel _ = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-Sort of like the needsCDecl, we need to stop the assembler from complaining
-about various data sections :-)
-\begin{code}
-#ifdef DPH
-needsApalDecl :: CLabel -> Bool
-needsApalDecl (IdLabel (CLabelId id) Closure) = not (isLocallyDefined id)
-needsApalDecl _ = False
-#endif {- Data Parallel Haskell -}
\end{code}
These GRAN functions are needed for spitting out GRAN_FETCH() at the
\begin{code}
pprCLabel :: PprStyle -> CLabel -> Unpretty
-pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u)
+pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u)
= uppStr (fmtAsmLbl (_UNPK_ (showUnique u)))
pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl
prLbl = pprCLabel (PprForC sw_chker) lbl
pprCLabel sty (TyConLabel tc UnvecConUpdCode)
- = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
- pp_cSEP, uppPStr SLIT("upd")]
+ = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc),
+ pp_cSEP, uppPStr SLIT("upd")]
pprCLabel sty (TyConLabel tc (VecConUpdCode tag))
= uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP,
pprCLabel sty (TyConLabel tc (StdUpdCode tag))
= case (ctrlReturnConvAlg tc) of
- UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
+ UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir")
VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG))
pprCLabel sty (TyConLabel tc InfoTblVecTbl)
= uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")]
pprCLabel sty (TyConLabel tc StdUpdVecTbl)
- = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
+ = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc),
pp_cSEP, uppPStr SLIT("upd")]
pprCLabel sty (CaseLabel u CaseReturnPt)
= uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u]
-pprCLabel sty (CaseLabel u CaseVecTbl)
+pprCLabel sty (CaseLabel u CaseVecTbl)
= uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u]
pprCLabel sty (CaseLabel u (CaseAlt tag))
= uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag]
-pprCLabel sty (CaseLabel u CaseDefault)
+pprCLabel sty (CaseLabel u CaseDefault)
= uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u]
pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode")
pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info")
-pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
- = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
+pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset))
+ = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset),
uppStr (if upd_reqd then "upd" else "noupd"),
uppPStr SLIT("__")]
-pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
- = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
+pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset))
+ = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset),
uppStr (if upd_reqd then "upd" else "noupd"),
uppPStr SLIT("__")]
pprCLabel sty (IdLabel (CLabelId id) flavor)
= uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor)
-#ifdef DPH
-pprCLabel sty (ALocalLabel u str) = uppBeside (uppStr str) (ppr_u u)
-#endif {- Data Parallel Haskell -}
-
ppr_u u = prettyToUn (pprUnique u)
ppFlavor :: IdLabelInfo -> Unpretty
-#ifndef DPH
+
ppFlavor x = uppBeside pp_cSEP
- (case x of
+ (case x of
Closure -> uppPStr SLIT("closure")
InfoTbl -> uppPStr SLIT("info")
EntryStd -> uppPStr SLIT("entry")
VapEntry False -> uppPStr SLIT("vap_noupd_entry")
RednCounts -> uppPStr SLIT("ct")
)
-#else
-ppFlavor x = uppStr (case x of
- Closure -> "_clos"
- InfoTbl -> "_info"
- EntryStd -> "_entry"
- EntryFast arity -> "_fast" ++ show arity
- ConEntry -> "_entry"
- StaticConEntry -> "_statentr"
- StaticInfoTbl -> "_statinfo"
- PhantomInfoTbl -> "_irinfo"
- -- ToDo: add more
- )
-#endif {- Data Parallel Haskell -}
-
\end{code}
-ToDo:
-use Z as escape char
-\begin{verbatim}
-_ main separator
-
-orig becomes
-**** *******
-_ Zu
-' Zq (etc for ops ??)
-<funny char> Z[hex-digit][hex-digit]
-Prelude<x> ZP<x>
-<std class> ZC<?>
-<std tycon> ZT<?>
-\end{verbatim}
-
-\begin{code}
-cSEP = SLIT("_") -- official C separator
-pp_cSEP = uppChar '_'
-
-identToC :: FAST_STRING -> Pretty
-modnameToC :: FAST_STRING -> FAST_STRING
-stringToC :: String -> String
-charToC, charToEasyHaskell :: Char -> String
-
--- stringToC: the hassle is what to do w/ strings like "ESC 0"...
-
-stringToC "" = ""
-stringToC [c] = charToC c
-stringToC (c:cs)
- -- if we have something "octifiable" in "c", we'd better "octify"
- -- the rest of the string, too.
- = if (c < ' ' || c > '~')
- then (charToC c) ++ (concat (map char_to_C cs))
- else (charToC c) ++ (stringToC cs)
- where
- char_to_C c | c == '\n' = "\\n" -- use C escapes when we can
- | c == '\a' = "\\a"
- | c == '\b' = "\\b" -- ToDo: chk some of these...
- | c == '\r' = "\\r"
- | c == '\t' = "\\t"
- | c == '\f' = "\\f"
- | c == '\v' = "\\v"
- | otherwise = '\\' : (octify (ord c))
-
--- OLD?: stringToC str = concat (map charToC str)
-
-charToC c = if (c >= ' ' && c <= '~') -- non-portable...
- then case c of
- '\'' -> "\\'"
- '\\' -> "\\\\"
- '"' -> "\\\""
- '\n' -> "\\n"
- '\a' -> "\\a"
- '\b' -> "\\b"
- '\r' -> "\\r"
- '\t' -> "\\t"
- '\f' -> "\\f"
- '\v' -> "\\v"
- _ -> [c]
- else '\\' : (octify (ord c))
-
--- really: charToSimpleHaskell
-
-charToEasyHaskell c
- = if (c >= 'a' && c <= 'z')
- || (c >= 'A' && c <= 'Z')
- || (c >= '0' && c <= '9')
- then [c]
- else case c of
- _ -> '\\' : 'o' : (octify (ord c))
-
-octify :: Int -> String
-octify n
- = if n < 8 then
- [chr (n + ord '0')]
- else
- octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
-
-identToC ps
- = let
- str = _UNPK_ ps
- in
- ppBeside
- (case str of
- 's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
- ppChar 'Z'
- _ -> ppNil)
-
- (if (all isAlphanum str) -- we gamble that this test will succeed...
- then ppPStr ps
- else ppIntersperse ppNil (map char_to_c str))
- where
- char_to_c 'Z' = ppPStr SLIT("ZZ")
- char_to_c '&' = ppPStr SLIT("Za")
- char_to_c '|' = ppPStr SLIT("Zb")
- char_to_c ':' = ppPStr SLIT("Zc")
- char_to_c '/' = ppPStr SLIT("Zd")
- char_to_c '=' = ppPStr SLIT("Ze")
- char_to_c '>' = ppPStr SLIT("Zg")
- char_to_c '#' = ppPStr SLIT("Zh")
- char_to_c '<' = ppPStr SLIT("Zl")
- char_to_c '-' = ppPStr SLIT("Zm")
- char_to_c '!' = ppPStr SLIT("Zn")
- char_to_c '.' = ppPStr SLIT("Zo")
- char_to_c '+' = ppPStr SLIT("Zp")
- char_to_c '\'' = ppPStr SLIT("Zq")
- char_to_c '*' = ppPStr SLIT("Zt")
- char_to_c '_' = ppPStr SLIT("Zu")
-
- char_to_c c = if isAlphanum c
- then ppChar c
- else ppBeside (ppChar 'Z') (ppInt (ord c))
-\end{code}
-
-For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
-chars) in the name. Rare.
-\begin{code}
-modnameToC ps
- = let
- str = _UNPK_ ps
- in
- if not (any quote_here str) then
- ps
- else
- _PK_ (concat (map char_to_c str))
- where
- quote_here '\'' = True
- quote_here _ = False
-
- char_to_c c
- = if isAlphanum c then [c] else 'Z' : (show (ord c))
-\end{code}
--- /dev/null
+This module deals with printing (a) C string literals and (b) C labels.
+
+\begin{code}
+#include "HsVersions.h"
+
+module CStrings(
+
+ cSEP,
+ pp_cSEP,
+
+ identToC, modnameToC,
+ stringToC, charToC,
+ charToEasyHaskell
+
+ ) where
+
+CHK_Ubiq() -- debugging consistency check
+
+import Pretty
+import Unpretty( uppChar )
+\end{code}
+
+
+\begin{verbatim}
+_ is the main separator
+
+orig becomes
+**** *******
+_ Zu
+' Zq (etc for ops ??)
+<funny char> Z[hex-digit][hex-digit]
+Prelude<x> ZP<x>
+<std class> ZC<?>
+<std tycon> ZT<?>
+\end{verbatim}
+
+\begin{code}
+cSEP = SLIT("_") -- official C separator
+pp_cSEP = uppChar '_'
+
+identToC :: FAST_STRING -> Pretty
+modnameToC :: FAST_STRING -> FAST_STRING
+stringToC :: String -> String
+charToC, charToEasyHaskell :: Char -> String
+
+-- stringToC: the hassle is what to do w/ strings like "ESC 0"...
+
+stringToC "" = ""
+stringToC [c] = charToC c
+stringToC (c:cs)
+ -- if we have something "octifiable" in "c", we'd better "octify"
+ -- the rest of the string, too.
+ = if (c < ' ' || c > '~')
+ then (charToC c) ++ (concat (map char_to_C cs))
+ else (charToC c) ++ (stringToC cs)
+ where
+ char_to_C c | c == '\n' = "\\n" -- use C escapes when we can
+ | c == '\a' = "\\a"
+ | c == '\b' = "\\b" -- ToDo: chk some of these...
+ | c == '\r' = "\\r"
+ | c == '\t' = "\\t"
+ | c == '\f' = "\\f"
+ | c == '\v' = "\\v"
+ | otherwise = '\\' : (octify (ord c))
+
+charToC c = if (c >= ' ' && c <= '~') -- non-portable...
+ then case c of
+ '\'' -> "\\'"
+ '\\' -> "\\\\"
+ '"' -> "\\\""
+ '\n' -> "\\n"
+ '\a' -> "\\a"
+ '\b' -> "\\b"
+ '\r' -> "\\r"
+ '\t' -> "\\t"
+ '\f' -> "\\f"
+ '\v' -> "\\v"
+ _ -> [c]
+ else '\\' : (octify (ord c))
+
+-- really: charToSimpleHaskell
+
+charToEasyHaskell c
+ = if (c >= 'a' && c <= 'z')
+ || (c >= 'A' && c <= 'Z')
+ || (c >= '0' && c <= '9')
+ then [c]
+ else case c of
+ _ -> '\\' : 'o' : (octify (ord c))
+
+octify :: Int -> String
+octify n
+ = if n < 8 then
+ [chr (n + ord '0')]
+ else
+ octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
+
+identToC ps
+ = let
+ str = _UNPK_ ps
+ in
+ ppBeside
+ (case str of
+ 's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
+ ppChar 'Z'
+ _ -> ppNil)
+
+ (if (all isAlphanum str) -- we gamble that this test will succeed...
+ then ppPStr ps
+ else ppIntersperse ppNil (map char_to_c str))
+ where
+ char_to_c 'Z' = ppPStr SLIT("ZZ")
+ char_to_c '&' = ppPStr SLIT("Za")
+ char_to_c '|' = ppPStr SLIT("Zb")
+ char_to_c ':' = ppPStr SLIT("Zc")
+ char_to_c '/' = ppPStr SLIT("Zd")
+ char_to_c '=' = ppPStr SLIT("Ze")
+ char_to_c '>' = ppPStr SLIT("Zg")
+ char_to_c '#' = ppPStr SLIT("Zh")
+ char_to_c '<' = ppPStr SLIT("Zl")
+ char_to_c '-' = ppPStr SLIT("Zm")
+ char_to_c '!' = ppPStr SLIT("Zn")
+ char_to_c '.' = ppPStr SLIT("Zo")
+ char_to_c '+' = ppPStr SLIT("Zp")
+ char_to_c '\'' = ppPStr SLIT("Zq")
+ char_to_c '*' = ppPStr SLIT("Zt")
+ char_to_c '_' = ppPStr SLIT("Zu")
+
+ char_to_c c = if isAlphanum c
+ then ppChar c
+ else ppBeside (ppChar 'Z') (ppInt (ord c))
+\end{code}
+
+For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
+chars) in the name. Rare.
+\begin{code}
+modnameToC ps
+ = let
+ str = _UNPK_ ps
+ in
+ if not (any quote_here str) then
+ ps
+ else
+ _PK_ (concat (map char_to_c str))
+ where
+ quote_here '\'' = True
+ quote_here _ = False
+
+ char_to_c c
+ = if isAlphanum c then [c] else 'Z' : (show (ord c))
+\end{code}
+
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Costs where
-import AbsCSyn(AbstractC, CAddrMode)
-data CostRes = Cost (Int, Int, Int, Int, Int)
-data Side = Lhs | Rhs
-addrModeCosts :: CAddrMode -> Side -> CostRes
-costs :: AbstractC -> CostRes
-nullCosts :: CostRes
-instance Eq CostRes
-instance Num CostRes
-instance Text CostRes
-
abstract~C Program the costs of executing that program. This is done by the
exported function:
-\begin{quote}
+\begin{quote}
{\verb type CostRes = (Int, Int, Int, Int, Int)}
{\verb costs :: AbstractC -> CostRes }
\end{quote}
\item The fourth component ({\tt s}) counts the number of store
instructions.
\item The fifth component ({\tt f}) counts the number of floating point
- instructions.
+ instructions.
\end{itemize}
-
+
This function is needed in GrAnSim for parallelism.
These are first suggestions for scaling the costs. But, this scaling should be done in the RTS rather than the compiler (this really should be tunable!):
#define INT_ARITHM_COSTS 1
#define GMP_ARITHM_COSTS 3 {- any clue for GMP costs ? -}
#define FLOAT_ARITHM_COSTS 3 {- any clue for float costs ? -}
-#define BRANCH_COSTS 2
+#define BRANCH_COSTS 2
\end{pseudocode}
\begin{code}
#include "HsVersions.h"
-#define ACCUM_COSTS(i,b,l,s,f) (i+b+l+s+f)
+#define ACCUM_COSTS(i,b,l,s,f) (i+b+l+s+f)
-#define NUM_REGS 10 {- PprAbsCSyn.lhs -} {- runtime/c-as-asm/CallWrap_C.lc -}
+#define NUM_REGS 10 {- PprAbsCSyn.lhs -} {- runtime/c-as-asm/CallWrap_C.lc -}
#define RESTORE_COSTS (Cost (0, 0, NUM_REGS, 0, 0) :: CostRes)
#define SAVE_COSTS (Cost (0, 0, 0, NUM_REGS, 0) :: CostRes)
-#define CCALL_COSTS_GUESS (Cost (50, 0, 0, 0, 0) :: CostRes)
+#define CCALL_COSTS_GUESS (Cost (50, 0, 0, 0, 0) :: CostRes)
module Costs( costs,
- addrModeCosts, CostRes(Cost), nullCosts, Side(..)
+ addrModeCosts, CostRes(Cost), nullCosts, Side(..)
) where
-import AbsCFuns
+import AbsCUtils
import AbsCSyn
-import AbsPrel
-import PrimOps
+import PrelInfo
+import PrimOp
import TyCon
import Util
#ifndef GRAN
-- a module of "stubs" that don't do anything
data CostRes = Cost (Int, Int, Int, Int, Int)
-data Side = Lhs | Rhs
+data Side = Lhs | Rhs
nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes
nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes
initHdrCosts = Cost (2, 0, 0, 1, 0) :: CostRes
-errorCosts = Cost (-1, -1, -1, -1, -1) -- just for debugging
+errorCosts = Cost (-1, -1, -1, -1, -1) -- just for debugging
oneArithm = Cost (1, 0, 0, 0, 0) :: CostRes
instance Eq CostRes where
(==) t1 t2 = i && b && l && s && f
- where (i,b,l,s,f) = binOp' (==) t1 t2
+ where (i,b,l,s,f) = binOp' (==) t1 t2
instance Num CostRes where
(+) = binOp (+)
(-) = binOp (-)
(*) = binOp (*)
- negate = mapOp negate
- abs = mapOp abs
- signum = mapOp signum
+ negate = mapOp negate
+ abs = mapOp abs
+ signum = mapOp signum
mapOp :: (Int -> Int) -> CostRes -> CostRes
mapOp g ( Cost (i, b, l, s, f) ) = Cost (g i, g b, g l, g s, g f)
foldrOp o x ( Cost (i1, b1, l1, s1, f1) ) =
i1 `o` ( b1 `o` ( l1 `o` ( s1 `o` ( f1 `o` x))))
-binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes
+binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes
binOp o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) =
- ( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) )
+ ( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) )
-binOp' :: (Int -> Int -> a) -> CostRes -> CostRes -> (a,a,a,a,a)
+binOp' :: (Int -> Int -> a) -> CostRes -> CostRes -> (a,a,a,a,a)
binOp' o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) =
- (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2)
+ (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2)
-- --------------------------------------------------------------------------
-data Side = Lhs | Rhs
+data Side = Lhs | Rhs
deriving (Eq)
-- --------------------------------------------------------------------------
costs :: AbstractC -> CostRes
-costs absC =
+costs absC =
case absC of
- AbsCNop -> nullCosts
+ AbsCNop -> nullCosts
- AbsCStmts absC1 absC2 -> costs absC1 + costs absC2
+ AbsCStmts absC1 absC2 -> costs absC1 + costs absC2
- CAssign (CReg _) (CReg _) -> Cost (1,0,0,0,0) -- typ.: mov %reg1,%reg2
+ CAssign (CReg _) (CReg _) -> Cost (1,0,0,0,0) -- typ.: mov %reg1,%reg2
- CAssign (CReg _) (CTemp _ _) -> Cost (1,0,0,0,0)
+ CAssign (CReg _) (CTemp _ _) -> Cost (1,0,0,0,0)
- CAssign (CReg _) (CAddr _) -> Cost (1,0,0,0,0) -- typ.: add %reg1,<adr>,%reg2
+ CAssign (CReg _) (CAddr _) -> Cost (1,0,0,0,0) -- typ.: add %reg1,<adr>,%reg2
- CAssign target_m source_m -> addrModeCosts target_m Lhs +
- addrModeCosts source_m Rhs
+ CAssign target_m source_m -> addrModeCosts target_m Lhs +
+ addrModeCosts source_m Rhs
- CJump (CLbl _ _) -> Cost (0,1,0,0,0) -- no ld for call necessary
+ CJump (CLbl _ _) -> Cost (0,1,0,0,0) -- no ld for call necessary
- CJump mode -> addrModeCosts mode Rhs +
+ CJump mode -> addrModeCosts mode Rhs +
Cost (0,1,0,0,0)
- CFallThrough mode -> addrModeCosts mode Rhs + -- chu' 0.24
- Cost (0,1,0,0,0)
-
+ CFallThrough mode -> addrModeCosts mode Rhs + -- chu' 0.24
+ Cost (0,1,0,0,0)
+
CReturn mode info -> case info of
- DirectReturn -> addrModeCosts mode Rhs +
- Cost (0,1,0,0,0)
+ DirectReturn -> addrModeCosts mode Rhs +
+ Cost (0,1,0,0,0)
- -- i.e. ld address to reg and call reg
+ -- i.e. ld address to reg and call reg
- DynamicVectoredReturn mode' ->
- addrModeCosts mode Rhs +
+ DynamicVectoredReturn mode' ->
+ addrModeCosts mode Rhs +
addrModeCosts mode' Rhs +
- Cost (0,1,1,0,0)
-
+ Cost (0,1,1,0,0)
+
{- generates code like this:
JMP_(<mode>)[RVREL(<mode'>)];
- i.e. 1 possb ld for mode'
- 1 ld for RVREL
+ i.e. 1 possb ld for mode'
+ 1 ld for RVREL
1 possb ld for mode
1 call -}
- StaticVectoredReturn _ -> addrModeCosts mode Rhs +
- Cost (0,1,1,0,0)
+ StaticVectoredReturn _ -> addrModeCosts mode Rhs +
+ Cost (0,1,1,0,0)
-- as above with mode' fixed to CLit
- -- typically 2 ld + 1 call; 1st ld due
- -- to CVal as mode
+ -- typically 2 ld + 1 call; 1st ld due
+ -- to CVal as mode
CSwitch mode alts absC -> nullCosts
{- for handling costs of all branches of
a CSwitch see PprAbsC.
- Basically:
- Costs for branch =
- Costs before CSwitch +
+ Basically:
+ Costs for branch =
+ Costs before CSwitch +
addrModeCosts of head +
Costs for 1 cond branch +
Costs for body of branch
-}
- CCodeBlock _ absC -> costs absC
+ CCodeBlock _ absC -> costs absC
CInitHdr cl_info reg_rel cost_centre inplace_upd -> initHdrCosts
{- This is more fancy but superflous: The addr modes
are fixed and so the costs are const!
- argCosts + initHdrCosts
+ argCosts + initHdrCosts
where argCosts = addrModeCosts (CAddr reg_rel) Rhs +
addrModeCosts base_lbl + -- CLbl!
- 3*addrModeCosts (mkIntCLit 1{- any val -})
+ 3*addrModeCosts (mkIntCLit 1{- any val -})
-}
{- this extends to something like
SET_SPEC_HDR(...)
- For costing the args of this macro
+ For costing the args of this macro
see PprAbsC.lhs where args are inserted -}
COpStmt modes_res primOp modes_args _ _ ->
- {-
- let
- n = length modes_res
- in
+ {-
+ let
+ n = length modes_res
+ in
(0, 0, n, n, 0) +
- primOpCosts primOp +
- if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
- else nullCosts
+ primOpCosts primOp +
+ if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
+ else nullCosts
-- ^^HWL
-}
- foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res] +
- foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args] +
- primOpCosts primOp +
- if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
- else nullCosts
-
- CSimultaneous absC -> costs absC
+ foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res] +
+ foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args] +
+ primOpCosts primOp +
+ if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS
+ else nullCosts
- CMacroStmt macro modes -> stmtMacroCosts macro modes
+ CSimultaneous absC -> costs absC
- CCallProfCtrMacro _ _ -> nullCosts
+ CMacroStmt macro modes -> stmtMacroCosts macro modes
+
+ CCallProfCtrMacro _ _ -> nullCosts
{- we don't count profiling in GrAnSim -}
- CCallProfCCMacro _ _ -> nullCosts
+ CCallProfCCMacro _ _ -> nullCosts
{- we don't count profiling in GrAnSim -}
-- *** the next three [or so...] are DATA (those above are CODE) ***
- -- as they are data rather than code they all have nullCosts -- HWL
+ -- as they are data rather than code they all have nullCosts -- HWL
CStaticClosure _ _ _ _ -> nullCosts
-
+
CClosureInfoAndCode _ _ _ _ _ _ -> nullCosts
-
- CRetVector _ _ _ -> nullCosts
-
- CRetUnVector _ _ -> nullCosts
-
- CFlatRetVector _ _ -> nullCosts
-
- CCostCentreDecl _ _ -> nullCosts
-
- CClosureUpdInfo _ -> nullCosts
-
- CSplitMarker -> nullCosts
+
+ CRetVector _ _ _ -> nullCosts
+
+ CRetUnVector _ _ -> nullCosts
+
+ CFlatRetVector _ _ -> nullCosts
+
+ CCostCentreDecl _ _ -> nullCosts
+
+ CClosureUpdInfo _ -> nullCosts
+
+ CSplitMarker -> nullCosts
-- ---------------------------------------------------------------------------
addrModeCosts addr_mode side =
let
lhs = side == Lhs
- in
+ in
case addr_mode of
CVal _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
+ else Cost (0, 0, 1, 0, 0)
CAddr _ -> if lhs then Cost (0, 0, 0, 1, 0) -- ??unchecked
- else Cost (0, 0, 1, 0, 0)
+ else Cost (0, 0, 1, 0, 0)
- CReg _ -> nullCosts {- loading from, storing to reg is free ! -}
+ CReg _ -> nullCosts {- loading from, storing to reg is free ! -}
{- for costing CReg->Creg ops see special -}
- {- case in costs fct -}
+ {- case in costs fct -}
CTableEntry base_mode offset_mode kind ->
- addrModeCosts base_mode side +
+ addrModeCosts base_mode side +
addrModeCosts offset_mode side +
Cost (1,0,1,0,0)
CTemp _ _ -> nullCosts {- if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0) -}
+ else Cost (0, 0, 1, 0, 0) -}
-- ``Temporaries'' correspond to local variables in C, and registers in
-- native code.
-- I assume they can be somewhat optimized by gcc -- HWL
CLbl _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (2, 0, 0, 0, 0)
+ else Cost (2, 0, 0, 0, 0)
-- Rhs: typically: sethi %hi(lbl),%tmp_reg
- -- or %tmp_reg,%lo(lbl),%target_reg
+ -- or %tmp_reg,%lo(lbl),%target_reg
CUnVecLbl _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (2, 0, 0, 0, 0)
+ else Cost (2, 0, 0, 0, 0)
-- same as CLbl
- -- Check the following 3 (checked form CLit on)
+ -- Check the following 3 (checked form CLit on)
CCharLike mode -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
+ else Cost (0, 0, 1, 0, 0)
CIntLike mode -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
+ else Cost (0, 0, 1, 0, 0)
- CString _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
+ CString _ -> if lhs then Cost (0, 0, 0, 1, 0)
+ else Cost (0, 0, 1, 0, 0)
- CLit _ -> if lhs then nullCosts -- should never occur
- else Cost (1, 0, 0, 0, 0) -- typ.: mov lit,%reg
+ CLit _ -> if lhs then nullCosts -- should never occur
+ else Cost (1, 0, 0, 0, 0) -- typ.: mov lit,%reg
- CLitLit _ _ -> if lhs then nullCosts
- else Cost (1, 0, 0, 0, 0)
+ CLitLit _ _ -> if lhs then nullCosts
+ else Cost (1, 0, 0, 0, 0)
-- same es CLit
- COffset _ -> if lhs then nullCosts
- else Cost (1, 0, 0, 0, 0)
+ COffset _ -> if lhs then nullCosts
+ else Cost (1, 0, 0, 0, 0)
-- same es CLit
- CCode absC -> costs absC
+ CCode absC -> costs absC
CLabelledCode _ absC -> costs absC
- CJoinPoint _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
+ CJoinPoint _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
+ else Cost (0, 0, 1, 0, 0)
CMacroExpr _ macro mode_list -> exprMacroCosts side macro mode_list
exprMacroCosts :: Side -> CExprMacro -> [CAddrMode] -> CostRes
-exprMacroCosts side macro mode_list =
+exprMacroCosts side macro mode_list =
let
- arg_costs = foldl (+) nullCosts
+ arg_costs = foldl (+) nullCosts
(map (\ x -> addrModeCosts x Rhs) mode_list)
in
arg_costs +
case macro of
INFO_PTR -> if side == Lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
- ENTRY_CODE -> nullCosts
+ else Cost (0, 0, 1, 0, 0)
+ ENTRY_CODE -> nullCosts
INFO_TAG -> if side == Lhs then Cost (0, 0, 0, 1, 0)
- else Cost (0, 0, 1, 0, 0)
+ else Cost (0, 0, 1, 0, 0)
EVAL_TAG -> if side == Lhs then Cost (1, 0, 0, 1, 0)
- else Cost (1, 0, 1, 0, 0)
+ else Cost (1, 0, 1, 0, 0)
-- costs of INFO_TAG + (1,0,0,0,0)
-- ---------------------------------------------------------------------------
stmtMacroCosts :: CStmtMacro -> [CAddrMode] -> CostRes
stmtMacroCosts macro modes =
- let
- arg_costs = foldl (+) nullCosts
- [addrModeCosts mode Rhs | mode <- modes]
+ let
+ arg_costs = foldl (+) nullCosts
+ [addrModeCosts mode Rhs | mode <- modes]
in
case macro of
- ARGS_CHK_A_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
+ ARGS_CHK_A_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
-- p=probability of PAP (instead of AP): + p*(3,1,0,0,0)
- ARGS_CHK_A -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
+ ARGS_CHK_A -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
-- p=probability of PAP (instead of AP): + p*(0,1,0,0,0)
- ARGS_CHK_B_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
- ARGS_CHK_B -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
- HEAP_CHK -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
- -- STK_CHK -> (2, 1, 0, 0, 0) {- StgMacros.lh -}
- STK_CHK -> Cost (0, 0, 0, 0, 0) {- StgMacros.lh -}
- UPD_CAF -> Cost (7, 0, 1, 3, 0) {- SMupdate.lh -}
- UPD_IND -> Cost (8, 2, 2, 0, 0) {- SMupdate.lh
+ ARGS_CHK_B_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
+ ARGS_CHK_B -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
+ HEAP_CHK -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -}
+ -- STK_CHK -> (2, 1, 0, 0, 0) {- StgMacros.lh -}
+ STK_CHK -> Cost (0, 0, 0, 0, 0) {- StgMacros.lh -}
+ UPD_CAF -> Cost (7, 0, 1, 3, 0) {- SMupdate.lh -}
+ UPD_IND -> Cost (8, 2, 2, 0, 0) {- SMupdate.lh
updatee in old-gen: Cost (4, 1, 1, 0, 0)
updatee in new-gen: Cost (4, 1, 1, 0, 0)
- NB: we include costs fo checking if there is
+ NB: we include costs fo checking if there is
a BQ, but we omit costs for awakening BQ
(these probably differ between old-gen and
- new gen) -}
- UPD_INPLACE_NOPTRS -> Cost (13, 3, 3, 2, 0) {- SMupdate.lh
+ new gen) -}
+ UPD_INPLACE_NOPTRS -> Cost (13, 3, 3, 2, 0) {- SMupdate.lh
common for both: Cost (4, 1, 1, 0, 0)
- updatee in old-gen: Cost (14, 3, 2, 4, 0)
+ updatee in old-gen: Cost (14, 3, 2, 4, 0)
updatee in new-gen: Cost (4, 1, 1, 0, 0) -}
- UPD_INPLACE_PTRS -> Cost (13, 3, 3, 2, 0) {- SMupdate.lh
+ UPD_INPLACE_PTRS -> Cost (13, 3, 3, 2, 0) {- SMupdate.lh
common for both: Cost (4, 1, 1, 0, 0)
- updatee in old-gen: Cost (14, 3, 2, 4, 0)
+ updatee in old-gen: Cost (14, 3, 2, 4, 0)
updatee in new-gen: Cost (4, 1, 1, 0, 0) -}
- UPD_BH_UPDATABLE -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
- UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
- PUSH_STD_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- SMupdate.lh -}
- POP_STD_UPD_FRAME -> Cost (1, 0, 3, 0, 0) {- SMupdate.lh -}
- SET_ARITY -> nullCosts {- StgMacros.lh -}
- CHK_ARITY -> nullCosts {- StgMacros.lh -}
- SET_TAG -> nullCosts {- COptRegs.lh -}
- GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -}
- GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
- GRAN_FETCH_AND_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
- THREAD_CONTEXT_SWITCH -> nullCosts {- GrAnSim bookkeeping -}
+ UPD_BH_UPDATABLE -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
+ UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
+ PUSH_STD_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- SMupdate.lh -}
+ POP_STD_UPD_FRAME -> Cost (1, 0, 3, 0, 0) {- SMupdate.lh -}
+ SET_ARITY -> nullCosts {- StgMacros.lh -}
+ CHK_ARITY -> nullCosts {- StgMacros.lh -}
+ SET_TAG -> nullCosts {- COptRegs.lh -}
+ GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -}
+ GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
+ GRAN_FETCH_AND_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
+ THREAD_CONTEXT_SWITCH -> nullCosts {- GrAnSim bookkeeping -}
-- ---------------------------------------------------------------------------
-floatOps :: [PrimOp]
+floatOps :: [PrimOp]
floatOps =
- [ FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp
+ [ FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp
, DoubleGtOp , DoubleGeOp , DoubleEqOp , DoubleNeOp , DoubleLtOp , DoubleLeOp
, FloatAddOp , FloatSubOp , FloatMulOp , FloatDivOp , FloatNegOp
, Float2IntOp , Int2FloatOp
- , FloatExpOp , FloatLogOp , FloatSqrtOp
- , FloatSinOp , FloatCosOp , FloatTanOp
+ , FloatExpOp , FloatLogOp , FloatSqrtOp
+ , FloatSinOp , FloatCosOp , FloatTanOp
, FloatAsinOp , FloatAcosOp , FloatAtanOp
, FloatSinhOp , FloatCoshOp , FloatTanhOp
, FloatPowerOp
, DoubleEncodeOp , DoubleDecodeOp
]
-gmpOps :: [PrimOp]
-gmpOps =
+gmpOps :: [PrimOp]
+gmpOps =
[ IntegerAddOp , IntegerSubOp , IntegerMulOp
, IntegerQuotRemOp , IntegerDivModOp , IntegerNegOp
, IntegerCmpOp
, Integer2IntOp , Int2IntegerOp
- , Addr2IntegerOp
+ , Addr2IntegerOp
]
-- Haven't found the .umul .div .rem macros yet
-- If they are not Haskell cde, they are not costed, yet
-abs_costs = nullCosts -- NB: This is normal STG code with costs already
+abs_costs = nullCosts -- NB: This is normal STG code with costs already
-- included; no need to add costs again.
-umul_costs = Cost (21,4,0,0,0) -- due to spy counts
-rem_costs = Cost (30,15,0,0,0) -- due to spy counts
-div_costs = Cost (30,15,0,0,0) -- due to spy counts
+umul_costs = Cost (21,4,0,0,0) -- due to spy counts
+rem_costs = Cost (30,15,0,0,0) -- due to spy counts
+div_costs = Cost (30,15,0,0,0) -- due to spy counts
primOpCosts :: PrimOp -> CostRes
-- Special cases
-primOpCosts (CCallOp _ _ _ _ _) = SAVE_COSTS + CCALL_COSTS_GUESS +
- RESTORE_COSTS -- GUESS; check it
+primOpCosts (CCallOp _ _ _ _ _) = SAVE_COSTS + CCALL_COSTS_GUESS +
+ RESTORE_COSTS -- GUESS; check it
-- Usually 3 mov instructions are needed to get args and res in right place.
primOpCosts DoubleGeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
primOpCosts DoubleEqOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp
primOpCosts DoubleNeOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp
-primOpCosts DoubleLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
+primOpCosts DoubleLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
primOpCosts DoubleLeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp
-primOpCosts FloatExpOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatLogOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatSqrtOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatSinOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatCosOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatTanOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatAsinOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatAcosOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatAtanOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatSinhOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatCoshOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatTanhOp = Cost (2, 1, 4, 4, 3)
---primOpCosts FloatAsinhOp = Cost (2, 1, 4, 4, 3)
---primOpCosts FloatAcoshOp = Cost (2, 1, 4, 4, 3)
---primOpCosts FloatAtanhOp = Cost (2, 1, 4, 4, 3)
-primOpCosts FloatPowerOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatExpOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatLogOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatSqrtOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatSinOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatCosOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatTanOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatAsinOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatAcosOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatAtanOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatSinhOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatCoshOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatTanhOp = Cost (2, 1, 4, 4, 3)
+--primOpCosts FloatAsinhOp = Cost (2, 1, 4, 4, 3)
+--primOpCosts FloatAcoshOp = Cost (2, 1, 4, 4, 3)
+--primOpCosts FloatAtanhOp = Cost (2, 1, 4, 4, 3)
+primOpCosts FloatPowerOp = Cost (2, 1, 4, 4, 3)
{- There should be special handling of the Array PrimOps in here HWL -}
-primOpCosts primOp
+primOpCosts primOp
| primOp `elem` floatOps = Cost (0, 0, 0, 0, 1) :: CostRes
- | primOp `elem` gmpOps = Cost (50, 5, 10, 10, 0) :: CostRes -- GUESS; check it
- | otherwise = Cost (1, 0, 0, 0, 0)
+ | primOp `elem` gmpOps = Cost (50, 5, 10, 10, 0) :: CostRes -- GUESS; check it
+ | otherwise = Cost (1, 0, 0, 0, 0)
-- ---------------------------------------------------------------------------
{- HWL: currently unused
-costsByKind :: PrimKind -> Side -> CostRes
+costsByKind :: PrimRep -> Side -> CostRes
-- The following PrimKinds say that the data is already in a reg
-costsByKind CharKind _ = nullCosts
-costsByKind IntKind _ = nullCosts
-costsByKind WordKind _ = nullCosts
-costsByKind AddrKind _ = nullCosts
-costsByKind FloatKind _ = nullCosts
-costsByKind DoubleKind _ = nullCosts
+costsByKind CharRep _ = nullCosts
+costsByKind IntRep _ = nullCosts
+costsByKind WordRep _ = nullCosts
+costsByKind AddrRep _ = nullCosts
+costsByKind FloatRep _ = nullCosts
+costsByKind DoubleRep _ = nullCosts
-}
-- ---------------------------------------------------------------------------
#endif {-GRAN-}
\end{code}
-This is the data structure of {\tt PrimOp} copied from prelude/PrimOps.lhs.
+This is the data structure of {\tt PrimOp} copied from prelude/PrimOp.lhs.
I include here some comments about the estimated costs for these @PrimOps@.
Compare with the @primOpCosts@ fct above. -- HWL
-- I assume all these basic comparisons take just one ALU instruction
-- Checked that for Char, Int; Word, Addr should be the same as Int.
- = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp
- | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp
- | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp
- | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp
+ = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp
+ | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp
+ | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp
+ | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp
-- Analogously, these take one FP unit instruction
-- Haven't checked that, yet.
- | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp
+ | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp
| DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp
-- 1 ALU op; unchecked
| OrdOp | ChrOp
-- these just take 1 ALU op; checked
- | IntAddOp | IntSubOp
+ | IntAddOp | IntSubOp
-- but these take more than that; see special cases in primOpCosts
-- I counted the generated ass. instructions for these -> checked
| FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp
| Float2IntOp | Int2FloatOp
- | FloatExpOp | FloatLogOp | FloatSqrtOp
- | FloatSinOp | FloatCosOp | FloatTanOp
+ | FloatExpOp | FloatLogOp | FloatSqrtOp
+ | FloatSinOp | FloatCosOp | FloatTanOp
| FloatAsinOp | FloatAcosOp | FloatAtanOp
| FloatSinhOp | FloatCoshOp | FloatTanhOp
-- not all machines have these available conveniently:
-- primitive ops for primitive arrays
| NewArrayOp
- | NewByteArrayOp PrimKind
+ | NewByteArrayOp PrimRep
| SameMutableArrayOp
| SameMutableByteArrayOp
| ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
- | ReadByteArrayOp PrimKind
- | WriteByteArrayOp PrimKind
- | IndexByteArrayOp PrimKind
- | IndexOffAddrOp PrimKind
- -- PrimKind can be one of {Char,Int,Addr,Float,Double}Kind.
- -- This is just a cheesy encoding of a bunch of ops.
- -- Note that MallocPtrKind is not included -- the only way of
- -- creating a MallocPtr is with a ccall or casm.
+ | ReadByteArrayOp PrimRep
+ | WriteByteArrayOp PrimRep
+ | IndexByteArrayOp PrimRep
+ | IndexOffAddrOp PrimRep
+ -- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
+ -- This is just a cheesy encoding of a bunch of ops.
+ -- Note that MallocPtrRep is not included -- the only way of
+ -- creating a MallocPtr is with a ccall or casm.
| UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
Note: From GrAn point of view, CCall is probably very expensive -- HWL
\begin{pseudocode}
- | CCallOp String -- An "unboxed" ccall# to this named function
- Bool -- True <=> really a "casm"
- Bool -- True <=> might invoke Haskell GC
- [UniType] -- Unboxed argument; the state-token
- -- argument will have been put *first*
- UniType -- Return type; one of the "StateAnd<blah>#" types
+ | CCallOp String -- An "unboxed" ccall# to this named function
+ Bool -- True <=> really a "casm"
+ Bool -- True <=> might invoke Haskell GC
+ [Type] -- Unboxed argument; the state-token
+ -- argument will have been put *first*
+ Type -- Return type; one of the "StateAnd<blah>#" types
-- (... to be continued ... )
\end{pseudocode}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface HeapOffs where
-import CharSeq(CSeq)
-import MachDesc(Target)
-import Maybes(Labda)
-import Pretty(PprStyle)
-import SMRep(SMRep)
-data HeapOffset
-type HpRelOffset = HeapOffset
-type SpARelOffset = Int
-type SpBRelOffset = Int
-type VirtualHeapOffset = HeapOffset
-type VirtualSpAOffset = Int
-type VirtualSpBOffset = Int
-addOff :: HeapOffset -> HeapOffset -> HeapOffset
-fixedHdrSize :: HeapOffset
-hpRelToInt :: Target -> HeapOffset -> Int
-intOff :: Int -> HeapOffset
-intOffsetIntoGoods :: HeapOffset -> Labda Int
-isZeroOff :: HeapOffset -> Bool
-maxOff :: HeapOffset -> HeapOffset -> HeapOffset
-possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool
-pprHeapOffset :: PprStyle -> HeapOffset -> CSeq
-subOff :: HeapOffset -> HeapOffset -> HeapOffset
-totHdrSize :: SMRep -> HeapOffset
-varHdrSize :: SMRep -> HeapOffset
-zeroOff :: HeapOffset
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[HeapOffs]{Abstract C: heap offsets}
#include "HsVersions.h"
module HeapOffs (
-#ifndef DPH
HeapOffset,
-#else
- HeapOffset(..), -- DPH needs to do a little peaking inside this thing.
-#endif {- Data Parallel Haskell -}
zeroOff, intOff, fixedHdrSize, totHdrSize, varHdrSize,
maxOff, addOff, subOff,
intOffsetIntoGoods,
+#if 0
#if ! OMIT_NATIVE_CODEGEN
- hpRelToInt,
+ hpRelToInt,
+#endif
#endif
VirtualHeapOffset(..), HpRelOffset(..),
VirtualSpAOffset(..), VirtualSpBOffset(..),
SpARelOffset(..), SpBRelOffset(..)
- ) where
+ ) where
+
+import Ubiq{-uitous-}
-import ClosureInfo -- esp. about SMReps
-import SMRep
+import ClosureInfo ( isSpecRep )
+import Maybes ( catMaybes )
+import SMRep
+import Unpretty -- ********** NOTE **********
+import Util ( panic )
#if ! OMIT_NATIVE_CODEGEN
-import MachDesc
+--import MachDesc ( Target )
#endif
-import Maybes ( catMaybes, Maybe(..) )
-import Outputable
-import Unpretty -- ********** NOTE **********
-import Util
\end{code}
%************************************************************************
* Node, the ptr to the closure, pts at its info-ptr field
-}
data HeapOffset
- = MkHeapOffset
+ = MkHeapOffset
FAST_INT -- this many words...
deriving () -- but: see `eqOff` below
-#if defined(__GLASGOW_HASKELL__)
data SMRep__Int = SMRI_ SMRep Int#
#define SMRI(a,b) (SMRI_ a b)
-#else
-type SMRep__Int = (SMRep, Int)
-#define SMRI(a,b) (a, b)
-#endif
type VirtualHeapOffset = HeapOffset
type VirtualSpAOffset = Int
fixedHdrSize = MkHeapOffset ILIT(0) ILIT(1) [] []
-totHdrSize sm_rep
+totHdrSize sm_rep
= if isSpecRep sm_rep -- Tot hdr size for a spec rep is just FixedHdrSize
then MkHeapOffset ILIT(0) ILIT(1) [] []
else MkHeapOffset ILIT(0) ILIT(0) [] [SMRI(sm_rep, ILIT(1))]
else
MaxHeapOffset off1 off2
where
- -- Normalise, by realising that each tot-hdr is really a
+ -- Normalise, by realising that each tot-hdr is really a
-- var-hdr plus a fixed-hdr
n_tothdr1 = total_of tothdr_offs1
real_fixed1 = fixhdr_offs1 _ADD_ n_tothdr1
add_HdrSizes as@(off1@(SMRI(rep1,n1)) : offs1) bs@(off2@(SMRI(rep2,n2)) : offs2)
= if rep1 `ltSMRepHdr` rep2 then
off1 : (add_HdrSizes offs1 bs)
- else
+ else
if rep2 `ltSMRepHdr` rep1 then
off2 : (add_HdrSizes as offs2)
else
\end{code}
\begin{code}
-pprHeapOffsetPieces :: PprStyle
+pprHeapOffsetPieces :: PprStyle
-> FAST_INT -- Words
-> FAST_INT -- Fixed hdrs
-> [SMRep__Int] -- Var hdrs
pp_hdr pp_str (SMRI(rep, n))
= if n _EQ_ ILIT(1) then
uppBeside (uppStr (show rep)) pp_str
- else
+ else
uppBesides [uppInt IBOX(n), uppChar '*', uppStr (show rep), pp_str]
\end{code}
\end{code}
\begin{code}
+#if 0
#if ! OMIT_NATIVE_CODEGEN
hpRelToInt :: Target -> HeapOffset -> Int
vhs_size r = (varHeaderSize target r) :: Int
#endif
+#endif {-0-}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PprAbsC where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import ClosureInfo(ClosureInfo)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import Stdio(_FILE)
-import Unique(Unique)
-data AbstractC
-data CAddrMode
-data MagicId
-data CSeq
-data PprStyle
-dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> [Char]
-pprAmode :: PprStyle -> CAddrMode -> CSeq
-writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> _State _RealWorld -> ((), _State _RealWorld)
-
#include "HsVersions.h"
module PprAbsC (
-#ifdef __GLASGOW_HASKELL__
writeRealC,
-#endif
dumpRealC,
-#if defined(DEBUG) || defined(DPH)
+#if defined(DEBUG)
pprAmode, -- otherwise, not exported
#endif
-#ifdef DPH
- pprAbsC,
- pprMagicId,
-#endif
-- and for interface self-sufficiency...
AbstractC, CAddrMode, MagicId,
import AbsCSyn
-import AbsPrel ( pprPrimOp, primOpNeedsWrapper, PrimOp(..)
+import PrelInfo ( pprPrimOp, primOpNeedsWrapper, PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
)
-import BasicLit ( kindOfBasicLit, showBasicLit )
-import CLabelInfo -- lots of things
+import Literal ( literalPrimRep, showLiteral )
+import CLabel -- lots of things
import CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
import CgRetConv ( noLiveRegsMask )
import ClosureInfo -- quite a few things
-import CmdLineOpts ( GlobalSwitch(..) )
import Costs -- for GrAnSim; cost counting function -- HWL
import CostCentre
import FiniteMap
import Maybes ( catMaybes, maybeToBool, Maybe(..) )
import Outputable
import Pretty ( codeStyle, prettyToUn )
-import PrimKind ( showPrimKind, isFloatingKind, PrimKind(..) )
-import SplitUniq
+import PrimRep ( showPrimRep, isFloatingRep, PrimRep(..) )
import StgSyn
import UniqFM
-import Unique -- UniqueSupply monadery used in flattening
import Unpretty -- ********** NOTE **********
import Util
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
-#ifdef __GLASGOW_HASKELL__
-# if __GLASGOW_HASKELL__ < 23
-# define _FILE _Addr
-# endif
-writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> PrimIO ()
+writeRealC :: _FILE -> AbstractC -> PrimIO ()
writeRealC sw_chker file absC
= uppAppendFile file 80 (
uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n')
)
-#endif
-dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> String
+dumpRealC :: AbstractC -> String
dumpRealC sw_chker absC
= uppShow 80 (
pp_paren_semi = uppStr ");"
-- ---------------------------------------------------------------------------
--- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
+-- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
-- code as an argument (that's needed when spitting out the GRAN_EXEC macro
-- which must be done before the return i.e. inside absC code) HWL
-- ---------------------------------------------------------------------------
pprAbsC sty (CClosureUpdInfo info) c
= pprAbsC sty info c
-pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeKind dest) dest src
+pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src
pprAbsC sty (CJump target) c
- = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ])
- (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
+ = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ])
+ (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
pprAbsC sty (CFallThrough target) c
- = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ])
- (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
+ = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ])
+ (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ])
-- --------------------------------------------------------------------------
--- Spit out GRAN_EXEC macro immediately before the return HWL
+-- Spit out GRAN_EXEC macro immediately before the return HWL
pprAbsC sty (CReturn am return_info) c
- = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ])
- (uppBesides [uppStr "JMP_(", target, pp_paren_semi ])
+ = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ])
+ (uppBesides [uppStr "JMP_(", target, pp_paren_semi ])
where
target = case return_info of
DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen]
DynamicVectoredReturn am' -> mk_vector (pprAmode sty am')
StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive
mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"]
-
-{-UNUSED:
-pprAbsC sty (CComment s) _
- = uppNil -- ifPprShowAll sty (uppCat [uppStr "/*", uppStr s, uppStr "*/"])
--}
pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */")
-- costs function yields nullCosts for whole switch
-- ==> inherited costs c are those of basic block up to switch
-- ==> inherit c + costs for the corresponding branch
--- HWL
+-- HWL
-- --------------------------------------------------------------------------
pprAbsC sty (CSwitch discrim [] deflt) c
empty_deflt = not (maybeToBool (nonemptyAbsC deflt))
pprAbsC sty (CSwitch discrim alts deflt) c -- general case
- | isFloatingKind (getAmodeKind discrim)
+ | isFloatingRep (getAmodeRep discrim)
= pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c
| otherwise
= uppAboves [
(case (nonemptyAbsC deflt) of
Nothing -> uppNil
Just dc ->
- uppNest 2 (uppAboves [uppPStr SLIT("default:"),
- pprAbsC sty dc (c + switch_head_cost
- + costs dc),
- uppPStr SLIT("break;")])),
+ uppNest 2 (uppAboves [uppPStr SLIT("default:"),
+ pprAbsC sty dc (c + switch_head_cost
+ + costs dc),
+ uppPStr SLIT("break;")])),
uppChar '}' ]
where
pp_discrim
ppr_alt sty (lit, absC)
= uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'],
- uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC))
- (uppPStr SLIT("break;"))) ]
+ uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC))
+ (uppPStr SLIT("break;"))) ]
-- Costs for addressing header of switch and cond. branching -- HWL
switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0))
pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
= let
non_void_args = grab_non_void_amodes args
- non_void_results = grab_non_void_amodes results
+ non_void_results = grab_non_void_amodes results
-- if just one result, we print in the obvious "assignment" style;
-- if 0 or many results, we emit a macro call, w/ the results
-- followed by the arguments. The macro presumably knows which
in
BIND (ppr_vol_regs sty vol_regs) _TO_ (pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
- uppAboves [ pp_saves,
+ uppAboves [ pp_saves,
the_op,
pp_restores
]
_ -> uppNil,
uppBesides [
uppStr "SET_STATIC_HDR(",
- pprCLabel sty closure_lbl, uppComma,
+ pprCLabel sty closure_lbl, uppComma,
pprCLabel sty info_lbl, uppComma,
- if_profiling sty (pprAmode sty cost_centre), uppComma,
- ppLocalness closure_lbl, uppComma,
+ if_profiling sty (pprAmode sty cost_centre), uppComma,
+ ppLocalness closure_lbl, uppComma,
ppLocalnessMacro False{-for data-} info_lbl,
uppChar ')'
],
info_lbl = infoTableLabelFromCI cl_info
ppr_item sty item
- = if getAmodeKind item == VoidKind
+ = if getAmodeRep item == VoidRep
then uppStr ", (W_) 0" -- might not even need this...
else uppBeside (uppStr ", (W_)") (ppr_amode sty item)
nOfThem still_needed (mkIntCLit 0) -- a bunch of 0s
BEND
-{-
+{-
STATIC_INIT_HDR(c,i,localness) blows into:
localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n>
pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
= uppAboves [
- uppBesides [
+ uppBesides [
pp_info_rep,
uppStr "_ITBL(",
pprCLabel sty info_lbl, uppComma,
- -- CONST_ITBL needs an extra label for
+ -- CONST_ITBL needs an extra label for
-- the static version of the object.
if isConstantRep sm_rep
then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma
pprCLabel sty slow_lbl, uppComma,
pprAmode sty upd, uppComma,
- uppInt liveness, uppComma,
+ uppInt liveness, uppComma,
pp_tag, uppComma,
pp_size, uppComma,
if_profiling sty pp_kind, uppComma,
if_profiling sty pp_descr, uppComma,
if_profiling sty pp_type,
- uppStr ");"
- ],
- pp_slow,
+ uppStr ");"
+ ],
+ pp_slow,
case maybe_fast of
- Nothing -> uppNil
- Just fast -> let stuff = CCodeBlock fast_lbl fast in
+ Nothing -> uppNil
+ Just fast -> let stuff = CCodeBlock fast_lbl fast in
pprAbsC sty stuff (costs stuff)
]
where
is_phantom = isPhantomRep sm_rep
pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always)
- uppInt (closureNonHdrSize cl_info)
+ uppInt (closureNonHdrSize cl_info)
else if is_phantom then -- do not have sizes for these
- uppNil
+ uppNil
else
- pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
+ pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info)
pp_ptr_wds = if is_phantom then
uppNil
ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc
-
-#ifdef DPH
--- Only used for debugging (i.e output abstractC instead of APAL)
-pprAbsC sty (CNativeInfoTableAndCode _ _ absC)
- = uppAboves [uppStr "CNativeInfoTableAndCode (DPH)",
- pprAbsC sty absC]
-#endif {- Data Parallel Haskell -}
\end{code}
\begin{code}
= filter non_void amodes
non_void amode
- = case (getAmodeKind amode) of
- VoidKind -> False
+ = case (getAmodeRep amode) of
+ VoidRep -> False
k -> True
\end{code}
= let pp_reg = case r of
VanillaReg pk n -> pprVanillaReg n
_ -> pprMagicId sty r
- (more_saves, more_restores) = ppr_vol_regs sty rs
+ (more_saves, more_restores) = ppr_vol_regs sty rs
in
(uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_")) pp_reg) more_saves,
uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores)
-- ---------------------------------------------------------------------------
-- Changes for GrAnSim:
-- draw costs for computation in head of if into both branches;
--- as no abstractC data structure is given for the head, one is constructed
--- guessing unknown values and fed into the costs function
+-- as no abstractC data structure is given for the head, one is constructed
+-- guessing unknown values and fed into the costs function
-- ---------------------------------------------------------------------------
do_if_stmt sty discrim tag alt_code deflt c
= case tag of
-- This special case happens when testing the result of a comparison.
-- We can just avoid some redundant clutter in the output.
- MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
+ MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim)
deflt alt_code
- (addrModeCosts discrim Rhs) c
+ (addrModeCosts discrim Rhs) c
other -> let
cond = uppBesides [ pprAmode sty discrim,
uppPStr SLIT(" == "),
pprAmode sty (CLit tag) ]
in
- ppr_if_stmt sty cond
+ ppr_if_stmt sty cond
alt_code deflt
(addrModeCosts discrim Rhs) c
ppr_if_stmt sty pp_pred then_part else_part discrim_costs c
= uppAboves [
uppBesides [uppStr "if (", pp_pred, uppStr ") {"],
- uppNest 8 (pprAbsC sty then_part (c + discrim_costs +
- (Cost (0, 2, 0, 0, 0)) +
+ uppNest 8 (pprAbsC sty then_part (c + discrim_costs +
+ (Cost (0, 2, 0, 0, 0)) +
costs then_part)),
(case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"),
- uppNest 8 (pprAbsC sty else_part (c + discrim_costs +
- (Cost (0, 1, 0, 0, 0)) +
+ uppNest 8 (pprAbsC sty else_part (c + discrim_costs +
+ (Cost (0, 1, 0, 0, 0)) +
costs else_part)),
uppChar '}' ]
{- Total costs = inherited costs (before if) + costs for accessing discrim
- + costs for cond branch ( = (0, 1, 0, 0, 0) )
+ + costs for cond branch ( = (0, 1, 0, 0, 0) )
+ costs for that alternative
-}
\end{code}
Some rough notes on generating code for @CCallOp@:
1) Evaluate all arguments and stuff them into registers. (done elsewhere)
-2) Save any essential registers (heap, stack, etc).
+2) Save any essential registers (heap, stack, etc).
ToDo: If stable pointers are in use, these must be saved in a place
where the runtime system can get at them so that the Stg world can
* make sure we save all our registers away where the garbage collector
can get at them.
* be sure that there are no live registers or we're in trouble.
- (This can cause problems if you try something foolish like passing
+ (This can cause problems if you try something foolish like passing
an array or mallocptr to a _ccall_GC_ thing.)
* increment/decrement the @inCCallGC@ counter before/after the call so
that the runtime check that PerformGC is being used sensibly will work.
(pp_saves, pp_restores) = ppr_vol_regs sty vol_regs
(pp_save_context, pp_restore_context) =
if may_gc
- then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
+ then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;",
uppStr "inCCallGC--; RestoreAllStgRegs();")
- else ( pp_basic_saves `uppAbove` pp_saves,
+ else ( pp_basic_saves `uppAbove` pp_saves,
pp_basic_restores `uppAbove` pp_restores)
- non_void_args =
- let nvas = tail args
+ non_void_args =
+ let nvas = tail args
in ASSERT (all non_void nvas) nvas
- -- the first argument will be the "I/O world" token (a VoidKind)
+ -- the first argument will be the "I/O world" token (a VoidRep)
-- all others should be non-void
- non_void_results =
- let nvrs = grab_non_void_amodes results
+ non_void_results =
+ let nvrs = grab_non_void_amodes results
in ASSERT (length nvrs <= 1) nvrs
-- there will usually be two results: a (void) state which we
-- should ignore and a (possibly void) result.
-- Remainder only used for ccall
ccall_str = uppShow 80
- (uppBesides [
- if null non_void_results
+ (uppBesides [
+ if null non_void_results
then uppNil
else uppPStr SLIT("%r = "),
- uppLparen, uppPStr op_str, uppLparen,
+ uppLparen, uppPStr op_str, uppLparen,
uppIntersperse uppComma ccall_args,
uppStr "));"
])
ppr_casm_arg sty amode a_num
= let
- a_kind = getAmodeKind amode
+ a_kind = getAmodeRep amode
pp_amode = pprAmode sty amode
pp_kind = pprPrimKind sty a_kind
-- for array arguments, pass a pointer to the body of the array
-- (PTRS_ARR_CTS skips over all the header nonsense)
- ArrayKind -> (pp_kind,
+ ArrayRep -> (pp_kind,
uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen])
- ByteArrayKind -> (pp_kind,
+ ByteArrayRep -> (pp_kind,
uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen])
-- for Malloc Pointers, use MALLOC_PTR_DATA to fish out the contents.
- MallocPtrKind -> (uppPStr SLIT("StgMallocPtr"),
+ MallocPtrRep -> (uppPStr SLIT("StgMallocPtr"),
uppBesides [uppStr "MallocPtr_CLOSURE_DATA(", pp_amode, uppStr")"])
other -> (pp_kind, pp_amode)
PprStyle -- style
-> [CAddrMode] -- list of results (length <= 1)
-> Unpretty -- liveness mask
- ->
+ ->
( Unpretty, -- declaration of any local vars
[Unpretty], -- list of result vars (same length as results)
Unpretty ) -- assignment (if any) of results in local var to registers
-ppr_casm_results sty [] liveness
+ppr_casm_results sty [] liveness
= (uppNil, [], uppNil) -- no results
ppr_casm_results sty [r] liveness
= let
result_reg = ppr_amode sty r
- r_kind = getAmodeKind r
+ r_kind = getAmodeRep r
local_var = uppPStr SLIT("_ccall_result")
(result_type, assign_result)
= case r_kind of
- MallocPtrKind ->
+ MallocPtrRep ->
(uppPStr SLIT("StgMallocPtr"),
- uppBesides [ uppStr "constructMallocPtr(",
+ uppBesides [ uppStr "constructMallocPtr(",
liveness, uppComma,
- result_reg, uppComma,
- local_var,
+ result_reg, uppComma,
+ local_var,
pp_paren_semi ])
- _ ->
+ _ ->
(pprPrimKind sty r_kind,
uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ]
- in
+ in
(declare_local_var, [local_var], assign_result)
-ppr_casm_results sty rs liveness
+ppr_casm_results sty rs liveness
= panic "ppr_casm_results: ccall/casm with many results"
\end{code}
Note the sneaky way _the_ result is represented by a list so that we
can complain if it's used twice.
-ToDo: Any chance of giving line numbers when process-casm fails?
+ToDo: Any chance of giving line numbers when process-casm fails?
Or maybe we should do a check _much earlier_ in compiler. ADR
\begin{code}
[Unpretty] -- results (length <= 1)
-> [Unpretty] -- arguments
-> String -- format string (with embedded %'s)
- ->
+ ->
Unpretty -- code being generated
process_casm results args string = process results args string
where
process [] _ "" = uppNil
- process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
+ process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n")
process ress args ('%':cs)
= case cs of
- [] ->
+ [] ->
error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n")
- ('%':css) ->
+ ('%':css) ->
uppBeside (uppChar '%') (process ress args css)
- ('r':css) ->
+ ('r':css) ->
case ress of
[] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n")
[r] -> uppBeside r (process [] args css)
other ->
case readDec other of
- [(num,css)] ->
+ [(num,css)] ->
if 0 <= num && num < length args
then uppBesides [uppLparen, args !! num, uppRparen,
process ress args css]
First of all, the kind of the thing being assigned can be gotten from
the destination addressing mode. (It should be the same as the kind
of the source addressing mode.) If the kind of the assignment is of
-@VoidKind@, then don't generate any code at all.
+@VoidRep@, then don't generate any code at all.
\begin{code}
-pprAssign :: PprStyle -> PrimKind -> CAddrMode -> CAddrMode -> Unpretty
+pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty
-pprAssign sty VoidKind dest src = uppNil
+pprAssign sty VoidRep dest src = uppNil
#if 0
pprAssign sty kind dest src
- | (kind /= getAmodeKind dest) || (kind /= getAmodeKind src)
+ | (kind /= getAmodeRep dest) || (kind /= getAmodeRep src)
= uppCat [uppStr "Bad kind:", pprPrimKind sty kind,
- pprPrimKind sty (getAmodeKind dest), pprAmode sty dest,
- pprPrimKind sty (getAmodeKind src), pprAmode sty src]
+ pprPrimKind sty (getAmodeRep dest), pprAmode sty dest,
+ pprPrimKind sty (getAmodeRep src), pprAmode sty src]
#endif
\end{code}
Special treatment for floats and doubles, to avoid unwanted conversions.
\begin{code}
-pprAssign sty FloatKind dest@(CVal reg_rel _) src
+pprAssign sty FloatRep dest@(CVal reg_rel _) src
= uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
-pprAssign sty DoubleKind dest@(CVal reg_rel _) src
+pprAssign sty DoubleRep dest@(CVal reg_rel _) src
= uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ]
\end{code}
Lastly, the question is: will the C compiler think the types of the
-two sides of the assignment match?
+two sides of the assignment match?
We assume that the types will match
if neither side is a @CVal@ addressing mode for any register
which can point into the heap or B stack.
Why? Because the heap and B stack are used to store miscellaneous things,
-whereas the A stack, temporaries, registers, etc., are only used for things
+whereas the A stack, temporaries, registers, etc., are only used for things
of fixed type.
\begin{code}
pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src))
- = uppBesides [ pprVanillaReg dest, uppEquals,
- pprVanillaReg src, uppSemi ]
+ = uppBesides [ pprVanillaReg dest, uppEquals,
+ pprVanillaReg src, uppSemi ]
pprAssign sty kind dest src
| mixedTypeLocn dest
-- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed
- = uppBesides [ ppr_amode sty dest, uppEquals,
+ = uppBesides [ ppr_amode sty dest, uppEquals,
uppStr "(W_)(", -- Here is the cast
ppr_amode sty src, pp_paren_semi ]
pprAssign sty kind dest src
- | mixedPtrLocn dest && getAmodeKind src /= PtrKind
+ | mixedPtrLocn dest && getAmodeRep src /= PtrRep
-- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed
- = uppBesides [ ppr_amode sty dest, uppEquals,
+ = uppBesides [ ppr_amode sty dest, uppEquals,
uppStr "(P_)(", -- Here is the cast
ppr_amode sty src, pp_paren_semi ]
-pprAssign sty ByteArrayKind dest src
+pprAssign sty ByteArrayRep dest src
| mixedPtrLocn src
-- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed
- = uppBesides [ ppr_amode sty dest, uppEquals,
+ = uppBesides [ ppr_amode sty dest, uppEquals,
uppStr "(B_)(", -- Here is the cast
ppr_amode sty src, pp_paren_semi ]
-
+
pprAssign sty kind other_dest src
- = uppBesides [ ppr_amode sty other_dest, uppEquals,
+ = uppBesides [ ppr_amode sty other_dest, uppEquals,
pprAmode sty src, uppSemi ]
\end{code}
question.)
\begin{code}
-pprAmode sty (CVal reg_rel FloatKind)
+pprAmode sty (CVal reg_rel FloatRep)
= uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ]
-pprAmode sty (CVal reg_rel DoubleKind)
+pprAmode sty (CVal reg_rel DoubleRep)
= uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ]
\end{code}
-Next comes the case where there is some other cast need, and the
+Next comes the case where there is some other cast need, and the
no-cast case:
\begin{code}
pprAmode sty amode
| mixedTypeLocn amode
- = uppBesides [ uppLparen, pprPrimKind sty (getAmodeKind amode), uppStr ")(",
+ = uppBesides [ uppLparen, pprPrimKind sty (getAmodeRep amode), uppStr ")(",
ppr_amode sty amode, uppRparen]
| otherwise -- No cast needed
= ppr_amode sty amode
(pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg
(pp_reg, Just offset) -> uppBesides [ pp_reg, uppLbrack, offset, uppRbrack ]
-ppr_amode sty (CAddr reg_rel)
+ppr_amode sty (CAddr reg_rel)
= case (pprRegRelative sty True{-sign wanted-} reg_rel) of
(pp_reg, Nothing) -> pp_reg
(pp_reg, Just offset) -> uppBeside pp_reg offset
ppr_amode sty (CLbl label kind) = pprCLabel sty label
-ppr_amode sty (CUnVecLbl direct vectored)
- = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma,
- pprCLabel sty vectored, uppRparen]
+ppr_amode sty (CUnVecLbl direct vectored)
+ = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma,
+ pprCLabel sty vectored, uppRparen]
-ppr_amode sty (CCharLike char)
+ppr_amode sty (CCharLike char)
= uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ]
-ppr_amode sty (CIntLike int)
+ppr_amode sty (CIntLike int)
= uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ]
ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"']
ppr_amode sty (CTableEntry base index kind)
= uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(",
- ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index,
+ ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index,
uppStr ")]"]
ppr_amode sty (CMacroExpr pk macro as)
- = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen,
- uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
+ = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen,
+ uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"]
ppr_amode sty (CCostCentre cc print_as_string)
= uppCostCentre sty print_as_string cc
pprSignedInt :: Bool -> Int -> Maybe Unpretty -- Nothing => 0
pprSignedInt sign_wanted n
- = if n == 0 then Nothing else
+ = if n == 0 then Nothing else
if n > 0 then Just (addPlusSign sign_wanted (uppInt n))
else Just (uppInt n)
-pprRegRelative :: PprStyle
+pprRegRelative :: PprStyle
-> Bool -- True <=> Print leading plus sign (if +ve)
- -> RegRelative
+ -> RegRelative
-> (Unpretty, Maybe Unpretty)
-pprRegRelative sty sign_wanted r@(SpARel spA off)
- = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt r))
+pprRegRelative sty sign_wanted (SpARel spA off)
+ = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off))
-pprRegRelative sty sign_wanted r@(SpBRel spB off)
- = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt r))
+pprRegRelative sty sign_wanted (SpBRel spB off)
+ = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt spB off))
pprRegRelative sty sign_wanted r@(HpRel hp off)
= let to_print = hp `subOff` off
\end{code}
@pprMagicId@ just prints the register name. @VanillaReg@ registers are
-represented by a discriminated union (@StgUnion@), so we use the @PrimKind@
+represented by a discriminated union (@StgUnion@), so we use the @PrimRep@
to select the union tag.
\begin{code}
pprMagicId sty BaseReg = uppPStr SLIT("BaseReg")
pprMagicId sty StkOReg = uppPStr SLIT("StkOReg")
pprMagicId sty (VanillaReg pk n)
- = uppBesides [ pprVanillaReg n, uppChar '.',
- pprUnionTag pk ]
+ = uppBesides [ pprVanillaReg n, uppChar '.',
+ pprUnionTag pk ]
pprMagicId sty (FloatReg n) = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n))
pprMagicId sty (DoubleReg n) = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n))
pprMagicId sty TagReg = uppPStr SLIT("TagReg")
pprMagicId sty Hp = uppPStr SLIT("Hp")
pprMagicId sty HpLim = uppPStr SLIT("HpLim")
pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg")
---UNUSED pprMagicId sty ActivityReg = uppPStr SLIT("ActivityReg")
pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg")
pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg")
pprMagicId sty CurCostCentre = uppPStr SLIT("CCC")
-pprMagicId sty VoidReg = {-uppStr "RetVoid!"-} panic "pprMagicId:VoidReg!"
-#ifdef DPH
-pprMagicId sty (DataReg _ n) = uppBeside (uppPStr SLIT("RD")) (uppInt n)
-#endif {- Data Parallel Haskell -}
+pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!"
pprVanillaReg :: FAST_INT -> Unpretty
pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n))
-pprUnionTag :: PrimKind -> Unpretty
+pprUnionTag :: PrimRep -> Unpretty
-pprUnionTag PtrKind = uppChar 'p'
-pprUnionTag CodePtrKind = uppPStr SLIT("fp")
-pprUnionTag DataPtrKind = uppChar 'd'
-pprUnionTag RetKind = uppChar 'r'
-pprUnionTag InfoPtrKind = uppChar 'd'
-pprUnionTag CostCentreKind = panic "pprUnionTag:CostCentre?"
+pprUnionTag PtrRep = uppChar 'p'
+pprUnionTag CodePtrRep = uppPStr SLIT("fp")
+pprUnionTag DataPtrRep = uppChar 'd'
+pprUnionTag RetRep = uppChar 'r'
+pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?"
-pprUnionTag CharKind = uppChar 'c'
-pprUnionTag IntKind = uppChar 'i'
-pprUnionTag WordKind = uppChar 'w'
-pprUnionTag AddrKind = uppChar 'v'
-pprUnionTag FloatKind = uppChar 'f'
-pprUnionTag DoubleKind = panic "pprUnionTag:Double?"
+pprUnionTag CharRep = uppChar 'c'
+pprUnionTag IntRep = uppChar 'i'
+pprUnionTag WordRep = uppChar 'w'
+pprUnionTag AddrRep = uppChar 'v'
+pprUnionTag FloatRep = uppChar 'f'
+pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
-pprUnionTag StablePtrKind = uppChar 'i'
-pprUnionTag MallocPtrKind = uppChar 'p'
+pprUnionTag StablePtrRep = uppChar 'i'
+pprUnionTag MallocPtrRep = uppChar 'p'
-pprUnionTag ArrayKind = uppChar 'p'
-pprUnionTag ByteArrayKind = uppChar 'b'
+pprUnionTag ArrayRep = uppChar 'p'
+pprUnionTag ByteArrayRep = uppChar 'b'
pprUnionTag _ = panic "pprUnionTag:Odd kind"
-
\end{code}
Just pp -> pp )
)
-pprBasicLit :: PprStyle -> BasicLit -> Unpretty
-pprPrimKind :: PprStyle -> PrimKind -> Unpretty
+pprBasicLit :: PprStyle -> Literal -> Unpretty
+pprPrimKind :: PprStyle -> PrimRep -> Unpretty
-pprBasicLit sty lit = uppStr (showBasicLit sty lit)
-pprPrimKind sty k = uppStr (showPrimKind k)
+pprBasicLit sty lit = uppStr (showLiteral sty lit)
+pprPrimKind sty k = uppStr (showPrimRep k)
\end{code}
= case sa (emptyUniqueSet, emptyCLabelSet) of { (_, result) ->
result }
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenTE #-}
{-# INLINE returnTE #-}
-#endif
thenTE :: TeM a -> (a -> TeM b) -> TeM b
thenTE a b u
\end{code}
\begin{code}
-pprTempDecl :: Unique -> PrimKind -> Unpretty
+pprTempDecl :: Unique -> PrimRep -> Unpretty
pprTempDecl uniq kind
= uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ]
ppr_for_C = PprForC ( \ x -> False ) -- pretend no special cmd-line flags
-pprExternDecl :: CLabel -> PrimKind -> Unpretty
+pprExternDecl :: CLabel -> PrimRep -> Unpretty
pprExternDecl clabel kind
= if not (needsCDecl clabel) then
else
BIND (
case kind of
- CodePtrKind -> ppLocalnessMacro True{-function-} clabel
+ CodePtrRep -> ppLocalnessMacro True{-function-} clabel
_ -> ppLocalnessMacro False{-data-} clabel
) _TO_ pp_macro_str ->
ppr_decls_AbsC (CClosureUpdInfo info)
= ppr_decls_AbsC info
---UNUSED: ppr_decls_AbsC (CComment comment) = returnTE (Nothing, Nothing)
-
ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing)
ppr_decls_AbsC (CAssign dest source)
if label_seen then
Nothing
else
- Just (pprExternDecl info_lbl PtrKind))
+ Just (pprExternDecl info_lbl PtrRep))
where
info_lbl = infoTableLabelFromCI cl_info
= ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
ppr_decls_AbsC slow `thenTE` \ p2 ->
(case maybe_fast of
- Nothing -> returnTE (Nothing, Nothing)
- Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
+ Nothing -> returnTE (Nothing, Nothing)
+ Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 ->
returnTE (maybe_uppAboves [p1, p2, p3])
where
- entry_lbl = CLbl slow_lbl CodePtrKind
+ entry_lbl = CLbl slow_lbl CodePtrRep
slow_lbl = case (nonemptyAbsC slow) of
Nothing -> mkErrorStdEntryLabel
Just _ -> entryLabelFromCI cl_info
ppr_decls_AbsC absC `thenTE` \ p2 ->
returnTE (maybe_uppAboves [p1, p2])
-ppr_decls_AbsC (CRetUnVector label amode)
- = ppr_decls_Amode amode
-
-ppr_decls_AbsC (CFlatRetVector label amodes)
- = ppr_decls_Amodes amodes
-
-#ifdef DPH
-ppr_decls_AbsC (CNativeInfoTableAndCode _ _ absC)
- = ppr_decls_AbsC absC
-#endif {- Data Parallel Haskell -}
+ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode
+ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes
\end{code}
\begin{code}
-- now, the only place where we actually print temps/externs...
ppr_decls_Amode (CTemp uniq kind)
= case kind of
- VoidKind -> returnTE (Nothing, Nothing)
+ VoidRep -> returnTE (Nothing, Nothing)
other ->
tempSeenTE uniq `thenTE` \ temp_seen ->
returnTE
(if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing)
-ppr_decls_Amode (CLbl label VoidKind)
+ppr_decls_Amode (CLbl label VoidRep)
= returnTE (Nothing, Nothing)
ppr_decls_Amode (CLbl label kind)
= labelSeenTE direct `thenTE` \ dlbl_seen ->
labelSeenTE vectored `thenTE` \ vlbl_seen ->
let
- ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrKind
- vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrKind
+ ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrRep
+ vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrRep
in
returnTE (Nothing,
if (dlbl_seen || not (needsCDecl direct)) &&
--labelSeenTE direct `thenTE` \ dlbl_seen ->
--labelSeenTE vectored `thenTE` \ vlbl_seen ->
let
- ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrKind
- vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrKind
+ ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrRep
+ vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrRep
in
returnTE (Nothing,
if ({-dlbl_seen ||-} not (needsCDecl direct)) &&
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface BasicLit where
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import UniType(UniType)
-data BasicLit = MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer)
-data PrimKind
-data UniType
-isLitLitLit :: BasicLit -> Bool
-isNoRepLit :: BasicLit -> Bool
-kindOfBasicLit :: BasicLit -> PrimKind
-mkMachInt :: Integer -> BasicLit
-mkMachWord :: Integer -> BasicLit
-showBasicLit :: PprStyle -> BasicLit -> [Char]
-typeOfBasicLit :: BasicLit -> UniType
-instance Eq BasicLit
-instance Ord BasicLit
-instance Outputable BasicLit
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CLabelInfo where
-import CharSeq(CSeq)
-import Id(Id)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import TyCon(TyCon)
-import Unique(Unique)
-data CLabel
-data Id
-data TyCon
-data Unique
-cSEP :: _PackedString
-charToC :: Char -> [Char]
-charToEasyHaskell :: Char -> [Char]
-externallyVisibleCLabel :: CLabel -> Bool
-identToC :: _PackedString -> Int -> Bool -> PrettyRep
-isAsmTemp :: CLabel -> Bool
-isReadOnly :: CLabel -> Bool
-mkAltLabel :: Unique -> Int -> CLabel
-mkAsmTempLabel :: Unique -> CLabel
-mkBlackHoleInfoTableLabel :: CLabel
-mkClosureLabel :: Id -> CLabel
-mkConEntryLabel :: Id -> CLabel
-mkConUpdCodePtrVecLabel :: TyCon -> Int -> CLabel
-mkDefaultLabel :: Unique -> CLabel
-mkErrorStdEntryLabel :: CLabel
-mkFastEntryLabel :: Id -> Int -> CLabel
-mkInfoTableLabel :: Id -> CLabel
-mkInfoTableVecTblLabel :: TyCon -> CLabel
-mkPhantomInfoTableLabel :: Id -> CLabel
-mkRednCountsLabel :: Id -> CLabel
-mkReturnPtLabel :: Unique -> CLabel
-mkStaticConEntryLabel :: Id -> CLabel
-mkStaticInfoTableLabel :: Id -> CLabel
-mkStdEntryLabel :: Id -> CLabel
-mkStdUpdCodePtrVecLabel :: TyCon -> Int -> CLabel
-mkStdUpdVecTblLabel :: TyCon -> CLabel
-mkVapEntryLabel :: Id -> Bool -> CLabel
-mkVapInfoTableLabel :: Id -> Bool -> CLabel
-mkVecTblLabel :: Unique -> CLabel
-modnameToC :: _PackedString -> _PackedString
-needsCDecl :: CLabel -> Bool
-pprCLabel :: PprStyle -> CLabel -> CSeq
-stringToC :: [Char] -> [Char]
-instance Eq CLabel
-instance Ord CLabel
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Id where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CharSeq(CSeq)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreExpr)
-import IdInfo(ArgUsageInfo, ArityInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, nullSpecEnv)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import InstEnv(InstTemplate)
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(NamedThing, Outputable)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
-import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyCon(Arity(..), TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import TyVarEnv(TypeEnv(..))
-import UniType(TauType(..), ThetaType(..), UniType)
-import UniqFM(UniqFM)
-import Unique(Unique, UniqueSupply)
-data Bag a
-data Class
-data ClassOp
-type ConTag = Int
-type DataCon = Id
-type DictFun = Id
-type DictVar = Id
-data GlobalSwitch
-data IdInfo
-data SpecEnv
-data SpecInfo
-data Inst
-data InstTemplate
-data Labda a
-data Name
-data FullName
-data Id
-data IdDetails
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data PrimKind
-data UnfoldingDetails
-data SrcLoc
-data Subst
-type Arity = Int
-data TyCon
-data TyVar
-data TyVarTemplate
-type TypeEnv = UniqFM UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType
-data UniqFM a
-data Unique
-data UniqueSupply
-addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
-addIdArity :: Id -> Int -> Id
-addIdDemandInfo :: Id -> DemandInfo -> Id
-addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
-addIdSpecialisation :: Id -> SpecEnv -> Id
-addIdStrictness :: Id -> StrictnessInfo -> Id
-addIdUnfolding :: Id -> UnfoldingDetails -> Id
-addIdUpdateInfo :: Id -> UpdateInfo -> Id
-applySubstToId :: Subst -> Id -> (Subst, Id)
-applyTypeEnvToId :: UniqFM UniType -> Id -> Id
-cmpId :: Id -> Id -> Int#
-cmpId_withSpecDataCon :: Id -> Id -> Int#
-eqId :: Id -> Id -> Bool
-externallyVisibleId :: Id -> Bool
-fIRST_TAG :: Int
-getDataConArity :: Id -> Int
-getDataConSig :: Id -> ([TyVarTemplate], [(Class, UniType)], [UniType], TyCon)
-getDataConTag :: Id -> Int
-getDataConTyCon :: Id -> TyCon
-getIdArgUsageInfo :: Id -> ArgUsageInfo
-getIdArity :: Id -> ArityInfo
-getIdDemandInfo :: Id -> DemandInfo
-getIdFBTypeInfo :: Id -> FBTypeInfo
-getIdInfo :: Id -> IdInfo
-getIdKind :: Id -> PrimKind
-getIdSpecialisation :: Id -> SpecEnv
-getIdStrictness :: Id -> StrictnessInfo
-getIdUnfolding :: Id -> UnfoldingDetails
-getIdUniType :: Id -> UniType
-getIdUpdateInfo :: Id -> UpdateInfo
-getInstIdModule :: Id -> _PackedString
-getInstNamePieces :: Bool -> Inst -> [_PackedString]
-getInstantiatedDataConSig :: Id -> [UniType] -> ([UniType], [UniType], UniType)
-getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
-idWantsToBeINLINEd :: Id -> Bool
-isBottomingId :: Id -> Bool
-isClassOpId :: Id -> Bool
-isConstMethodId_maybe :: Id -> Labda (Class, UniType, ClassOp)
-isDataCon :: Id -> Bool
-isDefaultMethodId_maybe :: Id -> Labda (Class, ClassOp, Bool)
-isDictFunId :: Id -> Bool
-isImportedId :: Id -> Bool
-isInstId_maybe :: Id -> Labda Inst
-isNullaryDataCon :: Id -> Bool
-isSpecId_maybe :: Id -> Labda (Id, [Labda UniType])
-isSpecPragmaId_maybe :: Id -> Labda (Labda SpecInfo)
-isSuperDictSelId_maybe :: Id -> Labda (Class, Class)
-isSysLocalId :: Id -> Bool
-isTopLevId :: Id -> Bool
-isTupleCon :: Id -> Bool
-isWorkerId :: Id -> Bool
-isWrapperId :: Id -> Bool
-localiseId :: Id -> Id
-mkClassOpId :: Unique -> Class -> ClassOp -> UniType -> IdInfo -> Id
-mkConstMethodId :: Unique -> Class -> ClassOp -> UniType -> UniType -> Bool -> _PackedString -> IdInfo -> Id
-mkDataCon :: Unique -> FullName -> [TyVarTemplate] -> [(Class, UniType)] -> [UniType] -> TyCon -> SpecEnv -> Id
-mkDefaultMethodId :: Unique -> Class -> ClassOp -> Bool -> UniType -> IdInfo -> Id
-mkDictFunId :: Unique -> Class -> UniType -> UniType -> Bool -> _PackedString -> IdInfo -> Id
-mkId :: Name -> UniType -> IdInfo -> Id
-mkIdWithNewUniq :: Id -> Unique -> Id
-mkImported :: Unique -> FullName -> UniType -> IdInfo -> Id
-mkInstId :: Inst -> Id
-mkPreludeId :: Unique -> FullName -> UniType -> IdInfo -> Id
-mkSameSpecCon :: [Labda UniType] -> Id -> Id
-mkSpecId :: Unique -> Id -> [Labda UniType] -> UniType -> IdInfo -> Id
-mkSpecPragmaId :: _PackedString -> Unique -> UniType -> Labda SpecInfo -> SrcLoc -> Id
-mkSuperDictSelId :: Unique -> Class -> Class -> UniType -> IdInfo -> Id
-mkSysLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id
-mkTemplateLocals :: [UniType] -> [Id]
-mkTupleCon :: Int -> Id
-mkUserLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id
-mkWorkerId :: Unique -> Id -> UniType -> IdInfo -> Id
-myWrapperMaybe :: Id -> Labda Id
-nullSpecEnv :: SpecEnv
-pprIdInUnfolding :: UniqFM Id -> Id -> Int -> Bool -> PrettyRep
-replaceIdInfo :: Id -> IdInfo -> Id
-selectIdInfoForSpecId :: Id -> IdInfo
-showId :: PprStyle -> Id -> [Char]
-toplevelishId :: Id -> Bool
-unfoldingUnfriendlyId :: Id -> Bool
-unlocaliseId :: _PackedString -> Id -> Labda Id
-updateIdType :: Id -> UniType -> Id
-whatsMentionedInId :: UniqFM Id -> Id -> (Bag Id, Bag TyCon, Bag Class)
-instance Eq Id
-instance Ord Id
-instance NamedThing Id
-instance Outputable Id
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Id]{@Ids@: Value and constructor identifiers}
\begin{code}
#include "HsVersions.h"
-module Id (
- Id, -- abstract
- IdInfo, -- re-exporting
+module Id {- (
+ GenId, Id(..), -- Abstract
+ StrictnessMark(..), -- An enumaration
ConTag(..), DictVar(..), DictFun(..), DataCon(..),
-- CONSTRUCTION
mkImported, mkPreludeId,
mkDataCon, mkTupleCon,
mkIdWithNewUniq,
- mkClassOpId, mkSuperDictSelId, mkDefaultMethodId,
- mkConstMethodId, mkInstId,
-#ifdef DPH
- mkProcessorCon,
- mkPodId,
-#endif {- Data Parallel Haskell -}
+ mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
+ mkConstMethodId, getConstMethodId,
updateIdType,
- mkId, mkDictFunId,
+ mkId, mkDictFunId, mkInstId,
mkWorkerId,
localiseId,
-- DESTRUCTION
- getIdUniType,
- getInstNamePieces, getIdInfo, replaceIdInfo,
- getIdKind, getInstIdModule,
+ idType,
+ getIdInfo, replaceIdInfo,
+ getPragmaInfo,
+ getIdPrimRep, getInstIdModule,
getMentionedTyConsAndClassesFromId,
getDataConTag,
getDataConSig, getInstantiatedDataConSig,
- getDataConTyCon, -- UNUSED: getDataConFamily,
-#ifdef USE_SEMANTIQUE_STRANAL
- getDataConDeps,
-#endif
+
+ getDataConTyCon,
-- PREDICATES
- isDataCon, isTupleCon, isNullaryDataCon,
+ isDataCon, isTupleCon,
isSpecId_maybe, isSpecPragmaId_maybe,
toplevelishId, externallyVisibleId,
isTopLevId, isWorkerId, isWrapperId,
isImportedId, isSysLocalId,
isBottomingId,
- isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
- isDictFunId, isInstId_maybe, isConstMethodId_maybe,
-#ifdef DPH
- isInventedTopLevId,
- isProcessorCon,
-#endif {- Data Parallel Haskell -}
- eqId, cmpId,
+ isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
+ isDictFunId,
+--??? isInstId_maybe,
+ isConstMethodId_maybe,
cmpId_withSpecDataCon,
myWrapperMaybe,
whatsMentionedInId,
getIdDemandInfo, addIdDemandInfo,
getIdSpecialisation, addIdSpecialisation,
getIdStrictness, addIdStrictness,
- getIdUnfolding, addIdUnfolding, -- UNUSED? clearIdUnfolding,
+ getIdUnfolding, addIdUnfolding,
getIdUpdateInfo, addIdUpdateInfo,
getIdArgUsageInfo, addIdArgUsageInfo,
getIdFBTypeInfo, addIdFBTypeInfo,
showId,
pprIdInUnfolding,
- -- and to make the interface self-sufficient...
- Class, ClassOp, GlobalSwitch, Inst, Maybe, Name,
- FullName, PprStyle, PrettyRep,
- PrimKind, SrcLoc, Pretty(..), Subst, UnfoldingDetails,
- TyCon, TyVar, TyVarTemplate, TauType(..), UniType, Unique,
- UniqueSupply, Arity(..), ThetaType(..),
- TypeEnv(..), UniqFM, InstTemplate, Bag,
- SpecEnv, nullSpecEnv, SpecInfo,
-
- -- and to make sure pragmas work...
- IdDetails -- from this module, abstract
- IF_ATTACK_PRAGMAS(COMMA getMentionedTyConsAndClassesFromUniType)
- IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
- IF_ATTACK_PRAGMAS(COMMA getInfo_UF)
-
-#ifndef __GLASGOW_HASKELL__
- , TAG_
-#endif
- ) where
+ -- "Environments" keyed off of Ids, and sets of Ids
+ IdEnv(..),
+ lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
+ growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
+ delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
+ rngIdEnv, mapIdEnv,
-IMPORT_Trace -- ToDo: rm (debugging only)
+ -- and to make the interface self-sufficient...
+ GenIdSet(..), IdSet(..)
+ )-} where
-import AbsPrel ( PrimOp, PrimKind, mkFunTy, nilDataCon, pRELUDE_BUILTIN
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-#ifdef DPH
- , mkPodNTy, mkPodizedPodNTy
-#endif {- Data Parallel Haskell -}
- )
+import Ubiq
+import IdLoop -- for paranoia checking
+import TyLoop -- for paranoia checking
+import NameLoop -- for paranoia checking
-import AbsUniType
import Bag
-import CLabelInfo ( identToC, cSEP )
-import CmdLineOpts ( GlobalSwitch(..) )
-import IdEnv -- ( nullIdEnv, IdEnv )
-import IdInfo -- piles of it
-import Inst -- lots of things
-import Maybes ( maybeToBool, Maybe(..) )
+import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
+import IdInfo
+import Maybes ( maybeToBool )
+import NameTypes ( mkShortName, fromPrelude, FullName, ShortName )
import Name ( Name(..) )
-import NameTypes
-import Outputable
-import Pretty -- for pretty-printing
-import SrcLoc
-import Subst ( applySubstToTy ) -- PRETTY GRIMY TO LOOK IN HERE
-import PlainCore
-import PrelFuns ( pcGenerateTupleSpecs ) -- PRETTY GRIMY TO LOOK IN HERE
+import Outputable ( isAvarop, isAconop, getLocalName,
+ isExported, ExportFlag(..) )
+import PragmaInfo ( PragmaInfo(..) )
+import PrelMods ( pRELUDE_BUILTIN )
+import PprType ( GenType, GenTyVar,
+ getTypeString, typeMaybeString, specMaybeTysSuffix )
+import PprStyle
+import Pretty
+import SrcLoc ( mkBuiltinSrcLoc )
+import TyCon ( TyCon, mkTupleTyCon, getTyConDataCons )
+import Type ( mkSigmaTy, mkTyVarTy, mkFunTys, mkDictTy,
+ applyTyCon, isPrimType, instantiateTy,
+ GenType, ThetaType(..), TauType(..), Type(..) )
+import TyVar ( GenTyVar, alphaTyVars )
import UniqFM
-import UniqSet
-import Unique
-import Util
-#ifdef DPH
-IMPORT_Trace
-import PodizeCore ( podizeTemplateExpr )
-import PodInfoTree ( infoTypeNumToMask )
-#endif {- Data Parallel Haskell -}
+import UniqSet ( UniqSet(..) )
+import Unique ( Unique, mkTupleDataConUnique, pprUnique, showUnique )
+import Util ( mapAccumL, nOfThem, panic, pprPanic, assertPanic )
\end{code}
Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
follow.
Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
-@UniType@, and an @IdInfo@ (non-essential info about it, e.g.,
+@Type@, and an @IdInfo@ (non-essential info about it, e.g.,
strictness). The essential info about different kinds of @Ids@ is
in its @IdDetails@.
ToDo: possibly cache other stuff in the single-constructor @Id@ type.
\begin{code}
-data Id = Id Unique -- key for fast comparison
- UniType -- Id's type; used all the time;
- IdInfo -- non-essential info about this Id;
- IdDetails -- stuff about individual kinds of Ids.
+data GenId ty = Id
+ Unique -- Key for fast comparison
+ ty -- Id's type; used all the time;
+ IdDetails -- Stuff about individual kinds of Ids.
+ PragmaInfo -- Properties of this Id requested by programmer
+ -- eg specialise-me, inline-me
+ IdInfo -- Properties of this Id deduced by compiler
+
+type Id = GenId Type
+
+data StrictnessMark = MarkedStrict | NotMarkedStrict
data IdDetails
Bool -- as for LocalId
| SpecPragmaId ShortName -- introduced by the compiler
- (Maybe SpecInfo)-- for explicit specid in pragma
- Bool -- as for LocalId
+ (Maybe Id) -- for explicit specid in pragma
+ Bool -- as for LocalId
---------------- Global values
| DataConId FullName
ConTag
- -- cached pieces of the type:
- [TyVarTemplate] [(Class,UniType)] [UniType] TyCon
- -- the type is:
- -- forall tyvars . theta_ty =>
- -- unitype_1 -> ... -> unitype_n -> tycon tyvars
- --
- -- "type ThetaType = [(Class, UniType)]"
+ [StrictnessMark] -- Strict args; length = arity
- -- The [TyVarTemplate] is in the same order as the args of the
- -- TyCon for the constructor
+ [TyVar] [(Class,Type)] [Type] TyCon
+ -- the type is:
+ -- forall tyvars . theta_ty =>
+ -- unitype_1 -> ... -> unitype_n -> tycon tyvars
| TupleConId Int -- Its arity
-#ifdef DPH
- | ProcessorCon Int -- Its arity
-#endif {- Data Parallel Haskell -}
-
---------------- Things to do with overloading
| SuperDictSelId -- Selector for superclass dictionary
Class -- The class (input dict)
Class -- The superclass (result dict)
- | ClassOpId Class -- An overloaded class operation, with
+ | MethodSelId Class -- An overloaded class operation, with
-- a fully polymorphic type. Its code
-- just selects a method from the
-- dictionary. The class.
ClassOp -- The operation
- -- NB: The IdInfo for a ClassOpId has all the info about its
+ -- NB: The IdInfo for a MethodSelId has all the info about its
-- related "constant method Ids", which are just
-- specialisations of this general one.
| DefaultMethodId -- Default method for a particular class op
- Class -- same class, <blah-blah> info as ClassOpId
+ Class -- same class, <blah-blah> info as MethodSelId
ClassOp -- (surprise, surprise)
Bool -- True <=> I *know* this default method Id
-- is a generated one that just says
-- `error "No default method for <op>"'.
+
+ -- see below
+ | DictFunId Class -- A DictFun is uniquely identified
+ Type -- by its class and type; this type has free type vars,
+ -- whose identity is irrelevant. Eg Class = Eq
+ -- Type = Tree a
+ -- The "a" is irrelevant. As it is too painful to
+ -- actually do comparisons that way, we kindly supply
+ -- a Unique for that purpose.
+ Bool -- True <=> from an instance decl in this mod
+ FAST_STRING -- module where instance came from
+
+ -- see below
+ | ConstMethodId -- A method which depends only on the type of the
+ -- instance, and not on any further dictionaries etc.
+ Class -- Uniquely identified by:
+ Type -- (class, type, classop) triple
+ ClassOp
+ Bool -- True <=> from an instance decl in this mod
+ FAST_STRING -- module where instance came from
+
+ | InstId ShortName -- An instance of a dictionary, class operation,
+ -- or overloaded value
+
+ | SpecId -- A specialisation of another Id
+ Id -- Id of which this is a specialisation
+ [Maybe Type] -- Types at which it is specialised;
+ -- A "Nothing" says this type ain't relevant.
+ Bool -- True <=> no free type vars; it's not enough
+ -- to know about the unspec version, because
+ -- we may specialise to a type w/ free tyvars
+ -- (i.e., in one of the "Maybe Type" dudes).
+
+ | WorkerId -- A "worker" for some other Id
+ Id -- Id for which this is a worker
+
+
+type ConTag = Int
+type DictVar = Id
+type DictFun = Id
+type DataCon = Id
\end{code}
+
DictFunIds are generated from instance decls.
\begin{verbatim}
class Foo a where
\end{verbatim}
generates
\begin{verbatim}
- dfun.Foo.[Int] = ...
+ dfun.Foo.[Int] = ...
\end{verbatim}
The type variables in the name are irrelevant; we print them as stars.
-\begin{code}
- | DictFunId Class -- A DictFun is uniquely identified
- UniType -- by its class and type; this type has free type vars,
- -- whose identity is irrelevant. Eg Class = Eq
- -- Type = Tree a
- -- The "a" is irrelevant. As it is too painful to
- -- actually do comparisons that way, we kindly supply
- -- a Unique for that purpose.
- Bool -- True <=> from an instance decl in this mod
- FAST_STRING -- module where instance came from
-\end{code}
Constant method ids are generated from instance decls where
there is no context; that is, no dictionaries are needed to
So a constant method is identified by a class/op/type triple.
The type variables in the type are irrelevant.
-\begin{code}
- | ConstMethodId -- A method which depends only on the type of the
- -- instance, and not on any further dictionaries etc.
- Class -- Uniquely identified by:
- UniType -- (class, type, classop) triple
- ClassOp
- Bool -- True <=> from an instance decl in this mod
- FAST_STRING -- module where instance came from
-
- | InstId Inst -- An instance of a dictionary, class operation,
- -- or overloaded value
-
- | SpecId -- A specialisation of another Id
- Id -- Id of which this is a specialisation
- [Maybe UniType] -- Types at which it is specialised;
- -- A "Nothing" says this type ain't relevant.
- Bool -- True <=> no free type vars; it's not enough
- -- to know about the unspec version, because
- -- we may specialise to a type w/ free tyvars
- -- (i.e., in one of the "Maybe UniType" dudes).
-
- | WorkerId -- A "worker" for some other Id
- Id -- Id for which this is a worker
-
-#ifdef DPH
- | PodId Int -- The dimension of the PODs context
- Int -- Which specialisation of InfoType is
- -- bind. ToDo(hilly): Int is a little messy
- -- and has a restricted range---change.
- Id -- One of the aboves Ids.
-#endif {- Data Parallel Haskell -}
-
-type ConTag = Int
-type DictVar = Id
-type DictFun = Id
-type DataCon = Id
-\end{code}
For Ids whose names must be known/deducible in other modules, we have
to conjure up their worker's names (and their worker's worker's
names... etc) in a known systematic way.
+
%************************************************************************
%* *
\subsection[Id-documentation]{Documentation}
[A BIT DATED [WDP]]
The @Id@ datatype describes {\em values}. The basic things we want to
-know: (1)~a value's {\em type} (@getIdUniType@ is a very common
+know: (1)~a value's {\em type} (@idType@ is a very common
operation in the compiler); and (2)~what ``flavour'' of value it might
be---for example, it can be terribly useful to know that a value is a
class method.
%----------------------------------------------------------------------
\item[@DataConId@:] For the data constructors declared by a @data@
declaration. Their type is kept in {\em two} forms---as a regular
-@UniType@ (in the usual place), and also in its constituent pieces (in
+@Type@ (in the usual place), and also in its constituent pieces (in
the ``details''). We are frequently interested in those pieces.
%----------------------------------------------------------------------
between (1) and (2), you're sunk!
%----------------------------------------------------------------------
-\item[@ClassOpId@:] A selector from a dictionary; it may select either
+\item[@MethodSelId@:] A selector from a dictionary; it may select either
a method or a dictionary for one of the class's superclasses.
%----------------------------------------------------------------------
\item
@DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
-@ClassOpIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
+@MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
properties:
\begin{itemize}
\item
properties, but they may not.
\end{enumerate}
-
%************************************************************************
%* *
\subsection[Id-general-funs]{General @Id@-related functions}
%************************************************************************
\begin{code}
-isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _)) = True
-isDataCon (Id _ _ _ (TupleConId _)) = True
-isDataCon (Id _ _ _ (SpecId unspec _ _)) = isDataCon unspec
-#ifdef DPH
-isDataCon (ProcessorCon _ _) = True
-isDataCon (PodId _ _ id ) = isDataCon id
-#endif {- Data Parallel Haskell -}
-isDataCon other = False
-
-isTupleCon (Id _ _ _ (TupleConId _)) = True
-isTupleCon (Id _ _ _ (SpecId unspec _ _)) = isTupleCon unspec
-#ifdef DPH
-isTupleCon (PodId _ _ id) = isTupleCon id
-#endif {- Data Parallel Haskell -}
-isTupleCon other = False
-
-isNullaryDataCon data_con
- = isDataCon data_con
- && (case arityMaybe (getIdArity data_con) of
- Just a -> a == 0
- _ -> panic "isNullaryDataCon")
-
-isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _))
+unsafeGenId2Id :: GenId ty -> Id
+unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
+
+isDataCon id = is_data (unsafeGenId2Id id)
+ where
+ is_data (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
+ is_data (Id _ _ (TupleConId _) _ _) = True
+ is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
+ is_data other = False
+
+
+isTupleCon id = is_tuple (unsafeGenId2Id id)
+ where
+ is_tuple (Id _ _ (TupleConId _) _ _) = True
+ is_tuple (Id _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
+ is_tuple other = False
+
+{-LATER:
+isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
= ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
Just (unspec, ty_maybes)
isSpecId_maybe other_id
= Nothing
-isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId _ specinfo _))
- = Just specinfo
+isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
+ = Just specid
isSpecPragmaId_maybe other_id
= Nothing
-
-#ifdef DPH
-isProcessorCon (ProcessorCon _ _) = True
-isProcessorCon (PodId _ _ id) = isProcessorCon id
-isProcessorCon other = False
-#endif {- Data Parallel Haskell -}
+-}
\end{code}
@toplevelishId@ tells whether an @Id@ {\em may} be defined in a
toplevelishId :: Id -> Bool
idHasNoFreeTyVars :: Id -> Bool
-toplevelishId (Id _ _ _ details)
+toplevelishId (Id _ _ details _ _)
= chk details
where
- chk (DataConId _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (ImportedId _) = True
- chk (PreludeId _) = True
- chk (TopLevId _) = True -- NB: see notes
- chk (SuperDictSelId _ _) = True
- chk (ClassOpId _ _) = True
- chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _ _) = True
+ chk (DataConId _ _ _ _ _ _ _) = True
+ chk (TupleConId _) = True
+ chk (ImportedId _) = True
+ chk (PreludeId _) = True
+ chk (TopLevId _) = True -- NB: see notes
+ chk (SuperDictSelId _ _) = True
+ chk (MethodSelId _ _) = True
+ chk (DefaultMethodId _ _ _) = True
+ chk (DictFunId _ _ _ _) = True
chk (ConstMethodId _ _ _ _ _) = True
- chk (SpecId unspec _ _) = toplevelishId unspec
+ chk (SpecId unspec _ _) = toplevelishId unspec
-- depends what the unspecialised thing is
- chk (WorkerId unwrkr) = toplevelishId unwrkr
- chk (InstId _) = False -- these are local
- chk (LocalId _ _) = False
- chk (SysLocalId _ _) = False
- chk (SpecPragmaId _ _ _) = False
-#ifdef DPH
- chk (ProcessorCon _ _) = True
- chk (PodId _ _ id) = toplevelishId id
-#endif {- Data Parallel Haskell -}
-
-idHasNoFreeTyVars (Id _ _ info details)
+ chk (WorkerId unwrkr) = toplevelishId unwrkr
+ chk (InstId _) = False -- these are local
+ chk (LocalId _ _) = False
+ chk (SysLocalId _ _) = False
+ chk (SpecPragmaId _ _ _) = False
+
+idHasNoFreeTyVars (Id _ _ details _ info)
= chk details
where
- chk (DataConId _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (ImportedId _) = True
- chk (PreludeId _) = True
- chk (TopLevId _) = True
- chk (SuperDictSelId _ _) = True
- chk (ClassOpId _ _) = True
- chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _ _) = True
+ chk (DataConId _ _ _ _ _ _ _) = True
+ chk (TupleConId _) = True
+ chk (ImportedId _) = True
+ chk (PreludeId _) = True
+ chk (TopLevId _) = True
+ chk (SuperDictSelId _ _) = True
+ chk (MethodSelId _ _) = True
+ chk (DefaultMethodId _ _ _) = True
+ chk (DictFunId _ _ _ _) = True
chk (ConstMethodId _ _ _ _ _) = True
- chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
- chk (InstId _) = False -- these are local
+ chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
+ chk (InstId _) = False -- these are local
chk (SpecId _ _ no_free_tvs) = no_free_tvs
chk (LocalId _ no_free_tvs) = no_free_tvs
chk (SysLocalId _ no_free_tvs) = no_free_tvs
chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
-#ifdef DPH
- chk (ProcessorCon _ _) = True
- chk (PodId _ _ id) = idHasNoFreeTyVars id
-#endif {- Data Parallel Haskell -}
\end{code}
\begin{code}
-isTopLevId (Id _ _ _ (TopLevId _)) = True
-#ifdef DPH
-isTopLevId (PodId _ _ id) = isTopLevId id
-#endif {- Data Parallel Haskell -}
-isTopLevId other = False
-
--- an "invented" one is a top-level Id, must be globally visible, etc.,
--- but it's slightly different in that it was "conjured up".
--- This handles workers fine, but may need refinement for other
--- conjured-up things (e.g., specializations)
--- NB: Only used in DPH now (93/08/20)
-
-#ifdef DPH
-ToDo: DPH
-isInventedTopLevId (TopLevId _ n _ _) = isInventedFullName n
-isInventedTopLevId (SpecId _ _ _) = True
-isInventedTopLevId (WorkerId _) = True
-isInventedTopLevId (PodId _ _ id) = isInventedTopLevId id
-isInventedTopLevId other = False
-#endif {- Data Parallel Haskell -}
-
-isImportedId (Id _ _ _ (ImportedId _)) = True
-#ifdef DPH
-isImportedId (PodId _ _ id) = isImportedId id
-#endif {- Data Parallel Haskell -}
-isImportedId other = False
-
-isBottomingId (Id _ _ info _) = bottomIsGuaranteed (getInfo info)
-#ifdef DPH
-isBottomingId (PodId _ _ id) = isBottomingId id
-#endif {- Data Parallel Haskell -}
---isBottomingId other = False
-
-isSysLocalId (Id _ _ _ (SysLocalId _ _)) = True
-#ifdef DPH
-isSysLocalId (PodId _ _ id) = isSysLocalId id
-#endif {- Data Parallel Haskell -}
-isSysLocalId other = False
-
-isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _ _)) = True
-#ifdef DPH
-isSpecPragmaId (PodId _ _ id) = isSpecPragmaId id
-#endif {- Data Parallel Haskell -}
-isSpecPragmaId other = False
-
-isClassOpId (Id _ _ _ (ClassOpId _ _)) = True
-isClassOpId _ = False
-
-isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err)) = Just (cls, clsop, err)
-#ifdef DPH
-isDefaultMethodId_maybe (PodId _ _ id) = isDefaultMethodId_maybe id
-#endif {- Data Parallel Haskell -}
-isDefaultMethodId_maybe other = Nothing
-
-isDictFunId (Id _ _ _ (DictFunId _ _ _ _)) = True
-#ifdef DPH
-isDictFunId (PodId _ _ id) = isDictFunId id
-#endif {- Data Parallel Haskell -}
-isDictFunId other = False
-
-isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _ _)) = Just (cls, ty, clsop)
-#ifdef DPH
-isConstMethodId_maybe (PodId _ _ id) = isConstMethodId_maybe id
-#endif {- Data Parallel Haskell -}
-isConstMethodId_maybe other = Nothing
-
-isInstId_maybe (Id _ _ _ (InstId inst)) = Just inst
-#ifdef DPH
-isInstId_maybe (PodId _ _ id) = isInstId_maybe id
-#endif {- Data Parallel Haskell -}
-isInstId_maybe other_id = Nothing
-
-isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc)) = Just (c, sc)
-#ifdef DPH
-isSuperDictSelId_maybe (PodId _ _ id) = isSuperDictSelId_maybe id
-#endif {- Data Parallel Haskell -}
-isSuperDictSelId_maybe other_id = Nothing
-
-isWorkerId (Id _ _ _ (WorkerId _)) = True
-#ifdef DPH
-isWorkerId (PodId _ _ id) = isWorkerId id
-#endif {- Data Parallel Haskell -}
-isWorkerId other = False
+isTopLevId (Id _ _ (TopLevId _) _ _) = True
+isTopLevId other = False
+
+isImportedId (Id _ _ (ImportedId _) _ _) = True
+isImportedId other = False
+isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented"
+ -- LATER: bottomIsGuaranteed (getInfo info)
+
+isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
+isSysLocalId other = False
+
+isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
+isSpecPragmaId other = False
+
+isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
+isMethodSelId _ = False
+
+isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
+isDefaultMethodId other = False
+
+isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
+ = Just (cls, clsop, err)
+isDefaultMethodId_maybe other = Nothing
+
+isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
+isDictFunId other = False
+
+isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
+isConstMethodId other = False
+
+isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
+ = Just (cls, ty, clsop)
+isConstMethodId_maybe other = Nothing
+
+isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
+isSuperDictSelId_maybe other_id = Nothing
+
+isWorkerId (Id _ _ (WorkerId _) _ _) = True
+isWorkerId other = False
+
+{-LATER:
isWrapperId id = workerExists (getIdStrictness id)
+-}
\end{code}
\begin{code}
+{-LATER:
pprIdInUnfolding :: IdSet -> Id -> Pretty
pprIdInUnfolding in_scopes v
= let
- v_ty = getIdUniType v
+ v_ty = idType v
in
-- local vars first:
if v `elementOfUniqSet` in_scopes then
- pprUnique (getTheUnique v)
+ pprUnique (getItsUnique v)
-- ubiquitous Ids with special syntax:
else if v == nilDataCon then
-- ones to think about:
else
let
- (Id _ _ _ v_details) = v
+ (Id _ _ v_details _ _) = v
in
case v_details of
-- these ones must have been exported by their original module
-- these ones' exportedness checked later...
TopLevId _ -> pp_full_name
- DataConId _ _ _ _ _ _ -> pp_full_name
+ DataConId _ _ _ _ _ _ _ -> pp_full_name
-- class-ish things: class already recorded as "mentioned"
SuperDictSelId c sc
-> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
- ClassOpId c o
+ MethodSelId c o
-> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
DefaultMethodId c o _
-> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
pp_class :: Class -> Pretty
pp_class_op :: ClassOp -> Pretty
- pp_type :: UniType -> Pretty
- pp_ty_maybe :: Maybe UniType -> Pretty
+ pp_type :: Type -> Pretty
+ pp_ty_maybe :: Maybe Type -> Pretty
pp_class clas = ppr ppr_Unfolding clas
pp_class_op op = ppr ppr_Unfolding op
pp_ty_maybe Nothing = ppPStr SLIT("_N_")
pp_ty_maybe (Just t) = pp_type t
+-}
\end{code}
@whatsMentionedInId@ ferrets out the types/classes/instances on which
call-tree decides that.
\begin{code}
+{-LATER:
whatsMentionedInId
:: IdSet -- Ids known to be in scope
-> Id -- Id being processed
whatsMentionedInId in_scopes v
= let
- v_ty = getIdUniType v
+ v_ty = idType v
(tycons, clss)
- = getMentionedTyConsAndClassesFromUniType v_ty
+ = getMentionedTyConsAndClassesFromType v_ty
result0 id_bag = (id_bag, tycons, clss)
-- ones to think about:
else
let
- (Id _ _ _ v_details) = v
+ (Id _ _ v_details _ _) = v
in
case v_details of
-- specialisations and workers
result1 ids2 tcs2 cs2
anything_else -> result0 (unitBag v) -- v is added to "mentioned"
+-}
\end{code}
Tell them who my wrapper function is.
\begin{code}
+{-LATER:
myWrapperMaybe :: Id -> Maybe Id
-myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper)) = Just my_wrapper
-myWrapperMaybe other_id = Nothing
+myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
+myWrapperMaybe other_id = Nothing
+-}
\end{code}
\begin{code}
-> Bool -- mentions this Id. Reason: it cannot
-- possibly be seen in another module.
+unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
+{-LATER:
+
unfoldingUnfriendlyId id
| not (externallyVisibleId id) -- that settles that...
= True
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper))
+unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
= class_thing wrapper
where
-- "class thing": If we're going to use this worker Id in
-- is not always possible: in precisely those cases where
-- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
- class_thing (Id _ _ _ (SuperDictSelId _ _)) = True
- class_thing (Id _ _ _ (ClassOpId _ _)) = True
- class_thing (Id _ _ _ (DefaultMethodId _ _ _)) = True
+ class_thing (Id _ _ (SuperDictSelId _ _) _ _) = True
+ class_thing (Id _ _ (MethodSelId _ _) _ _) = True
+ class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
class_thing other = False
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _))
+unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
-- a SPEC of a DictFunId can end up w/ gratuitous
-- TyVar(Templates) in the i/face; only a problem
-- if -fshow-pragma-name-errs; but we can do without the pain.
naughty_DictFunId dfun
--)
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _ _))
+unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
= --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
naughty_DictFunId dfun -- similar deal...
--)
naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
naughty_DictFunId (DictFunId _ ty _ _)
= not (isGroundTy ty)
+-}
\end{code}
@externallyVisibleId@: is it true that another module might be
\begin{code}
externallyVisibleId :: Id -> Bool
-externallyVisibleId id@(Id _ _ _ details)
+externallyVisibleId id = panic "Id.externallyVisibleId"
+{-LATER:
+
+externallyVisibleId id@(Id _ _ details _ _)
= if isLocallyDefined id then
toplevelishId id && isExported id && not (weird_datacon details)
else
-- of WeirdLocalType; but we need to know this when asked if
-- "Mumble" is externally visible...
- weird_datacon (DataConId _ _ _ _ _ tycon)
+ weird_datacon (DataConId _ _ _ _ _ _ tycon)
= maybeToBool (maybePurelyLocalTyCon tycon)
weird_datacon not_a_datacon_therefore_not_weird = False
weird_tuplecon (TupleConId arity)
= arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
weird_tuplecon _ = False
+-}
\end{code}
\begin{code}
+{-LATER:
idWantsToBeINLINEd :: Id -> Bool
idWantsToBeINLINEd id
= case (getIdUnfolding id) of
IWantToBeINLINEd _ -> True
_ -> False
+-}
\end{code}
For @unlocaliseId@: See the brief commentary in
\tr{simplStg/SimplStg.lhs}.
\begin{code}
+{-LATER:
unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
unlocaliseId mod (Id u ty info (TopLevId fn))
Nothing -> Nothing
Just xx -> Just (Id u ty info (WorkerId xx))
-unlocaliseId mod (Id u ty info (InstId inst))
+unlocaliseId mod (Id u ty info (InstId name))
= Just (Id u ty info (TopLevId full_name))
-- type might be wrong, but it hardly matters
-- at this stage (just before printing C) ToDo
where
- name = let (bit1:bits) = getInstNamePieces True inst in
- _CONCAT_ (bit1 : [ _CONS_ '.' b | b <- bits ])
-
- full_name = mkFullName mod (mod _APPEND_ name) InventedInThisModule ExportAll mkGeneratedSrcLoc
-
-#ifdef DPH
-unlocaliseId mod (PodId dim ity id)
- = case (unlocaliseId mod id) of
- Just id' -> Just (PodId dim ity id')
- Nothing -> Nothing
-#endif {- Data Parallel Haskell -}
+ name = getLocalName name
+ full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
unlocaliseId mod other_id = Nothing
unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
-- we're OK otherwise
+-}
\end{code}
CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
former ``should be'' the usual crunch point.
\begin{code}
+{-LATER:
applyTypeEnvToId :: TypeEnv -> Id -> Id
applyTypeEnvToId type_env id@(Id u ty info details)
= apply_to_Id ( \ ty ->
applyTypeEnvToTy type_env ty
) id
+-}
\end{code}
\begin{code}
-apply_to_Id :: (UniType -> UniType)
+{-LATER:
+apply_to_Id :: (Type -> Type)
-> Id
-> Id
in
WorkerId new_unwrkr
-#ifdef DPH
- apply_to_details (PodId d ity id )
- = PodId d ity (apply_to_Id ty_fn id)
-#endif {- Data Parallel Haskell -}
-
apply_to_details other = other
+-}
\end{code}
Sadly, I don't think the one using the magic typechecker substitution
with pointers to the substitution: it {\em must} be single-threaded.
\begin{code}
+{-LATER:
applySubstToId :: Subst -> Id -> (Subst, Id)
applySubstToId subst id@(Id u ty info details)
apply_to_details subst new_ty (SpecId unspec ty_maybes _)
= case (applySubstToId subst unspec) of { (s2, new_unspec) ->
- case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
+ case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
(s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
-- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
where
apply_to_details subst _ (WorkerId unwrkr)
= case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
- (s2, WorkerId new_unwrkr) }
+ (s2, WorkerId new_unwrkr) }
apply_to_details subst _ other = (subst, other)
-
-#ifdef DPH
-applySubstToId (PodId d ity id )
- = ???? ToDo:DPH; not sure what! returnLft (PodId d ity (applySubstToId id))
-#endif {- Data Parallel Haskell -}
+-}
\end{code}
\begin{code}
-getIdNamePieces :: Bool {-show Uniques-} -> Id -> [FAST_STRING]
-
-getIdNamePieces show_uniqs (Id u ty info details)
- = case details of
- DataConId n _ _ _ _ _ ->
+getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
+getIdNamePieces show_uniqs id
+ = get (unsafeGenId2Id id)
+ where
+ get (Id u _ details _ _)
+ = case details of
+ DataConId n _ _ _ _ _ _ ->
case (getOrigName n) of { (mod, name) ->
if fromPrelude mod then [name] else [mod, name] }
- TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))]
+ TupleConId 0 -> [SLIT("()")]
+ TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
- ImportedId n -> get_fullname_pieces n
- PreludeId n -> get_fullname_pieces n
- TopLevId n -> get_fullname_pieces n
+ ImportedId n -> get_fullname_pieces n
+ PreludeId n -> get_fullname_pieces n
+ TopLevId n -> get_fullname_pieces n
SuperDictSelId c sc ->
case (getOrigName c) of { (c_mod, c_name) ->
in
[SLIT("sdsel")] ++ c_bits ++ sc_bits }}
- ClassOpId clas op ->
+ MethodSelId clas op ->
case (getOrigName clas) of { (c_mod, c_name) ->
case (getClassOpString op) of { op_name ->
if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
c_bits = if fromPreludeCore c
then [c_name]
else [c_mod, c_name]
-
+
ty_bits = getTypeString ty
in
[SLIT("dfun")] ++ c_bits ++ ty_bits }
-- names of the types to which specialised...
SpecId unspec ty_maybes _ ->
- getIdNamePieces show_uniqs unspec ++ (
- if not (toplevelishId unspec)
- then [showUnique u]
- else concat (map typeMaybeString ty_maybes)
- )
+ get unspec ++ (if not (toplevelishId unspec)
+ then [showUnique u]
+ else concat (map typeMaybeString ty_maybes))
WorkerId unwrkr ->
- getIdNamePieces show_uniqs unwrkr ++ (
- if not (toplevelishId unwrkr)
- then [showUnique u]
- else [SLIT("wrk")] -- show u
- )
+ get unwrkr ++ (if not (toplevelishId unwrkr)
+ then [showUnique u]
+ else [SLIT("wrk")])
- InstId inst -> getInstNamePieces show_uniqs inst
LocalId n _ -> let local = getLocalName n in
- if show_uniqs then [local, showUnique u] else [local]
+ if show_uniqs then [local, showUnique u] else [local]
+ InstId n -> [getLocalName n, showUnique u]
SysLocalId n _ -> [getLocalName n, showUnique u]
SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
-#ifdef DPH
- ProcessorCon a _ -> ["MkProcessor" ++ (show a)]
- PodId n ity id -> getIdNamePieces show_uniqs id ++
- ["mapped", "POD" ++ (show n), show ity]
-#endif {- Data Parallel Haskell -}
-
get_fullname_pieces :: FullName -> [FAST_STRING]
get_fullname_pieces n
= BIND (getOrigName n) _TO_ (mod, name) ->
BEND
\end{code}
-Really Inst-ish, but only used in this module...
-\begin{code}
-getInstNamePieces :: Bool -> Inst -> [FAST_STRING]
-
-getInstNamePieces show_uniqs (Dict u clas ty _)
- = let (mod, nm) = getOrigName clas in
- if fromPreludeCore clas
- then [SLIT("d"), nm, showUnique u]
- else [SLIT("d"), mod, nm, showUnique u]
-
-getInstNamePieces show_uniqs (Method u id tys _)
- = let local = getIdNamePieces show_uniqs id in
- if show_uniqs then local ++ [showUnique u] else local
-
-getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u]
-\end{code}
-
%************************************************************************
%* *
\subsection[Id-type-funs]{Type-related @Id@ functions}
%************************************************************************
\begin{code}
-getIdUniType :: Id -> UniType
-
-getIdUniType (Id _ ty _ _) = ty
-
-#ifdef DPH
--- ToDo: DPH
-getIdUniType (ProcessorCon _ ty) = ty
-getIdUniType (PodId d ity id)
- = let (foralls,rho) = splitForalls (getIdUniType id) in
- let tys = get_args rho in
- let itys_mask = infoTypeNumToMask ity in
- let tys' = zipWith convert tys itys_mask in
- mkForallTy foralls (foldr1 mkFunTy tys')
- where -- ToDo(hilly) change to use getSourceType etc...
-
- get_args ty = case (maybeUnpackFunTy ty) of
- Nothing -> [ty]
- Just (arg,res) -> arg:get_args res
-
- convert ty cond = if cond
- then ty
- else (coerce ty)
-
- coerce ty = case (maybeUnpackFunTy ty) of
- Nothing ->mkPodizedPodNTy d ty
- Just (arg,res) ->mkFunTy (coerce arg) (coerce res)
-#endif {- Data Parallel Haskell -}
+idType :: GenId ty -> ty
+
+idType (Id _ ty _ _ _) = ty
\end{code}
\begin{code}
+{-LATER:
getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
getMentionedTyConsAndClassesFromId id
- = getMentionedTyConsAndClassesFromUniType (getIdUniType id)
+ = getMentionedTyConsAndClassesFromType (idType id)
+-}
\end{code}
\begin{code}
-getIdKind i = kindFromType (getIdUniType i)
+--getIdPrimRep i = primRepFromType (idType i)
\end{code}
\begin{code}
+{-LATER:
getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
getInstIdModule other = panic "Id:getInstIdModule"
-\end{code}
-
-
-\begin{code}
-{- NOT USED
-getIdTauType :: Id -> TauType
-getIdTauType i = expandTySyn (getTauType (getIdUniType i))
-
-getIdSourceTypes :: Id -> [TauType]
-getIdSourceTypes i = map expandTySyn (sourceTypes (getTauType (getIdUniType i)))
-
-getIdTargetType :: Id -> TauType
-getIdTargetType i = expandTySyn (targetType (getTauType (getIdUniType i)))
-}
\end{code}
%************************************************************************
\begin{code}
-mkSuperDictSelId u c sc ty info = Id u ty info (SuperDictSelId c sc)
-mkClassOpId u c op ty info = Id u ty info (ClassOpId c op)
-mkDefaultMethodId u c op gen ty info = Id u ty info (DefaultMethodId c op gen)
+mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
+mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
+mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
mkDictFunId u c ity full_ty from_here modname info
- = Id u full_ty info (DictFunId c ity from_here modname)
+ = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
mkConstMethodId u c op ity full_ty from_here modname info
- = Id u full_ty info (ConstMethodId c ity op from_here modname)
+ = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
-mkWorkerId u unwrkr ty info = Id u ty info (WorkerId unwrkr)
+mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
-mkInstId inst
- = Id u (getInstUniType inst) noIdInfo (InstId inst)
- where
- u = case inst of
- Dict u c t o -> u
- Method u i ts o -> u
- LitInst u l ty o -> u
-
-{- UNUSED:
-getSuperDictSelIdSig (Id _ _ _ (SuperDictSelId input_class result_class))
- = (input_class, result_class)
+mkInstId uniq ty name = Id uniq ty (InstId name) NoPragmaInfo noIdInfo
+
+{-LATER:
+getConstMethodId clas op ty
+ = -- constant-method info is hidden in the IdInfo of
+ -- the class-op id (as mentioned up above).
+ let
+ sel_id = getMethodSelId clas op
+ in
+ case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
+ Just xx -> xx
+ Nothing -> error (ppShow 80 (ppAboves [
+ ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op,
+ ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
+ ppr PprDebug sel_id],
+ ppStr "(This can arise if an interface pragma refers to an instance",
+ ppStr "but there is no imported interface which *defines* that instance.",
+ ppStr "The info above, however ugly, should indicate what else you need to import."
+ ]))
-}
\end{code}
%************************************************************************
\begin{code}
-mkImported u n ty info = Id u ty info (ImportedId n)
-mkPreludeId u n ty info = Id u ty info (PreludeId n)
-
-#ifdef DPH
-mkPodId d i = PodId d i
-#endif
+mkImported u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
+mkPreludeId u n ty info = Id u ty (PreludeId n) NoPragmaInfo info
-updateIdType :: Id -> UniType -> Id
+{-LATER:
+updateIdType :: Id -> Type -> Id
updateIdType (Id u _ info details) ty = Id u ty info details
+-}
\end{code}
\begin{code}
-no_free_tvs ty = null (extractTyVarsFromTy ty)
+no_free_tvs ty = panic "Id:no_free_tvs" -- null (extractTyVarsFromTy ty)
-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
-mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> UniType -> SrcLoc -> Id
+mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> ty -> SrcLoc -> GenId ty
mkSysLocal str uniq ty loc
- = Id uniq ty noIdInfo (SysLocalId (mkShortName str loc) (no_free_tvs ty))
+ = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
mkUserLocal str uniq ty loc
- = Id uniq ty noIdInfo (LocalId (mkShortName str loc) (no_free_tvs ty))
+ = Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
+
+-- mkUserId builds a local or top-level Id, depending on the name given
+mkUserId :: Name -> ty -> PragmaInfo -> GenId ty
+mkUserId (Short uniq short) ty pragma_info
+ = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
+mkUserId (ValName uniq full) ty pragma_info
+ = Id uniq ty
+ (if isLocallyDefined full then TopLevId full else ImportedId full)
+ pragma_info noIdInfo
+\end{code}
+
+
+\begin{code}
+{-LATER:
-- for a SpecPragmaId being created by the compiler out of thin air...
-mkSpecPragmaId :: FAST_STRING -> Unique -> UniType -> Maybe SpecInfo -> SrcLoc -> Id
-mkSpecPragmaId str uniq ty specinfo loc
- = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specinfo (no_free_tvs ty))
+mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
+mkSpecPragmaId str uniq ty specid loc
+ = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
--- for new SpecId
+-- for new SpecId
mkSpecId u unspec ty_maybes ty info
= ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
-- pprTrace "SameSpecCon:Unique:"
-- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))
--- mkId builds a local or top-level Id, depending on the name given
-mkId :: Name -> UniType -> IdInfo -> Id
-mkId (Short uniq short) ty info = Id uniq ty info (LocalId short (no_free_tvs ty))
-mkId (OtherTopId uniq full) ty info
- = Id uniq ty info
- (if isLocallyDefined full then TopLevId full else ImportedId full)
-
localiseId :: Id -> Id
localiseId id@(Id u ty info details)
= Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
mkIdWithNewUniq :: Id -> Unique -> Id
mkIdWithNewUniq (Id _ ty info details) uniq
- = let
- new_details
- = case details of
- InstId (Dict _ c t o) -> InstId (Dict uniq c t o)
- InstId (Method _ i ts o) -> InstId (Method uniq i ts o)
- InstId (LitInst _ l ty o) -> InstId (LitInst uniq l ty o)
- old_details -> old_details
- in
- Id uniq ty info new_details
-
-#ifdef DPH
-mkIdWithNewUniq (PodId d t id) uniq = PodId d t (mkIdWithNewUniq id uniq)
-#endif {- Data Parallel Haskell -}
+ = Id uniq ty info new_details
+-}
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
@Uniques@, but that's OK because the templates are supposed to be
instantiated before use.
\begin{code}
-mkTemplateLocals :: [UniType] -> [Id]
+{-LATER:
+mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals tys
= zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
(getBuiltinUniques (length tys))
tys
+-}
\end{code}
\begin{code}
-getIdInfo :: Id -> IdInfo
-
-getIdInfo (Id _ _ info _) = info
+getIdInfo :: GenId ty -> IdInfo
+getPragmaInfo :: GenId ty -> PragmaInfo
-#ifdef DPH
-getIdInfo (PodId _ _ id) = getIdInfo id
-#endif {- Data Parallel Haskell -}
+getIdInfo (Id _ _ _ _ info) = info
+getPragmaInfo (Id _ _ _ info _) = info
+{-LATER:
replaceIdInfo :: Id -> IdInfo -> Id
replaceIdInfo (Id u ty _ details) info = Id u ty info details
-#ifdef DPH
-replaceIdInfo (PodId dim ity id) info = PodId dim ity (replaceIdInfo id info)
-#endif {- Data Parallel Haskell -}
-
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
= ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
noIdInfo `addInfo_UF` getIdUnfolding unspec
+-}
\end{code}
%************************************************************************
besides the code-generator need arity info!)
\begin{code}
-getIdArity :: Id -> ArityInfo
-getDataConArity :: DataCon -> Int -- a simpler i/face; they always have arities
-
-#ifdef DPH
-getIdArity (ProcessorCon n _) = mkArityInfo n
-getIdArity (PodId _ _ id) = getIdArity id
-#endif {- Data Parallel Haskell -}
-
-getIdArity (Id _ _ id_info _) = getInfo id_info
+getIdArity :: Id -> ArityInfo
+getIdArity (Id _ _ _ _ id_info) = getInfo id_info
-getDataConArity id@(Id _ _ id_info _)
+getDataConArity :: DataCon -> Int
+getDataConArity id@(Id _ _ _ _ id_info)
= ASSERT(isDataCon id)
case (arityMaybe (getInfo id_info)) of
Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
Just i -> i
addIdArity :: Id -> Int -> Id
-addIdArity (Id u ty info details) arity
- = Id u ty (info `addInfo` (mkArityInfo arity)) details
+addIdArity (Id u ty details pinfo info) arity
+ = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-mkDataCon :: Unique{-DataConKey-} -> FullName -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
- -- can get the tag and all the pieces of the type from the UniType
-
-mkDataCon k n tyvar_tmpls context args_tys tycon specenv = data_con
+mkDataCon :: Unique{-DataConKey-}
+ -> FullName
+ -> [StrictnessMark]
+ -> [TyVar] -> ThetaType -> [TauType] -> TyCon
+--ToDo: -> SpecEnv
+ -> Id
+ -- can get the tag and all the pieces of the type from the Type
+
+mkDataCon k n stricts tvs ctxt args_tys tycon
+ = ASSERT(length stricts == length args_tys)
+ data_con
where
- data_con = Id k type_of_constructor datacon_info
- (DataConId n
- (position_within fIRST_TAG data_con_family data_con)
- tyvar_tmpls context args_tys tycon)
+ -- NB: data_con self-recursion; should be OK as tags are not
+ -- looked at until late in the game.
+ data_con
+ = Id k
+ type_of_constructor
+ (DataConId n data_con_tag stricts tvs ctxt args_tys tycon)
+ NoPragmaInfo
+ datacon_info
- -- Note data_con self-recursion;
- -- should be OK as tags are not looked at until
- -- late in the game.
+ data_con_tag = position_within fIRST_TAG data_con_family
- data_con_family = getTyConDataCons tycon
+ data_con_family = getTyConDataCons tycon
- position_within :: Int -> [Id] -> Id -> Int
- position_within acc [] con
- = panic "mkDataCon: con not found in family"
+ position_within :: Int -> [Id] -> Int
- position_within acc (c:cs) con
- = if c `eqId` con then acc else position_within (acc+(1::Int)) cs con
+ position_within acc (c:cs)
+ = if c == data_con then acc else position_within (acc+1) cs
+#ifdef DEBUG
+ position_within acc []
+ = panic "mkDataCon: con not found in family"
+#endif
- type_of_constructor = mkSigmaTy tyvar_tmpls context
- (glueTyArgs
- args_tys
- (applyTyCon tycon (map mkTyVarTemplateTy tyvar_tmpls)))
+ type_of_constructor
+ = mkSigmaTy tvs ctxt
+ (mkFunTys args_tys (applyTyCon tycon (map mkTyVarTy tvs)))
datacon_info = noIdInfo `addInfo_UF` unfolding
`addInfo` mkArityInfo arity
- `addInfo` specenv
+--ToDo: `addInfo` specenv
arity = length args_tys
unfolding
+ = noInfo_UF
+{- LATER:
= -- if arity == 0
-- then noIdInfo
-- else -- do some business...
let
- (tyvars, dict_vars, vars) = mk_uf_bits tyvar_tmpls context args_tys tycon
+ (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
tyvar_tys = map mkTyVarTy tyvars
in
- BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
-
- BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon ->
+ BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
mkUnfolding EssentialUnfolding -- for data constructors
- (foldr CoTyLam lambdized_CoCon tyvars)
- BEND BEND
+ (mkLam tyvars (dict_vars ++ vars) plain_Con)
+ BEND
- mk_uf_bits tyvar_tmpls context arg_tys tycon
+ mk_uf_bits tvs ctxt arg_tys tycon
= let
(inst_env, tyvars, tyvar_tys)
- = instantiateTyVarTemplates tyvar_tmpls
- (map getTheUnique tyvar_tmpls)
+ = instantiateTyVarTemplates tvs
+ (map getItsUnique tvs)
in
-- the "context" and "arg_tys" have TyVarTemplates in them, so
-- we instantiate those types to have the right TyVars in them
-- instead.
- BIND (map (instantiateTauTy inst_env) (map ctxt_ty context))
+ BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
_TO_ inst_dict_tys ->
BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
-- (Mega-Sigh) [ToDo]
BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
- BIND (splitAt (length context) all_vars) _TO_ (dict_vars, vars) ->
+ BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
(tyvars, dict_vars, vars)
BEND BEND BEND BEND
where
- -- these are really dubious UniTypes, but they are only to make the
+ -- these are really dubious Types, but they are only to make the
-- binders for the lambdas for tossed-away dicts.
ctxt_ty (clas, ty) = mkDictTy clas ty
+-}
\end{code}
\begin{code}
mkTupleCon :: Arity -> Id
-mkTupleCon arity = data_con
+mkTupleCon arity
+ = Id unique ty (TupleConId arity) NoPragmaInfo tuplecon_info
where
- data_con = Id unique ty tuplecon_info (TupleConId arity)
unique = mkTupleDataConUnique arity
- ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys))
+ ty = mkSigmaTy tyvars []
+ (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
tycon = mkTupleTyCon arity
tyvars = take arity alphaTyVars
- tyvar_tys = map mkTyVarTemplateTy tyvars
+ tyvar_tys = map mkTyVarTy tyvars
tuplecon_info
= noIdInfo `addInfo_UF` unfolding
`addInfo` mkArityInfo arity
- `addInfo` pcGenerateTupleSpecs arity ty
+--LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
unfolding
+ = noInfo_UF
+{- LATER:
= -- if arity == 0
-- then noIdInfo
-- else -- do some business...
(tyvars, dict_vars, vars) = mk_uf_bits arity
tyvar_tys = map mkTyVarTy tyvars
in
- BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
-
- BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon ->
+ BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
mkUnfolding
EssentialUnfolding -- data constructors
- (foldr CoTyLam lambdized_CoCon tyvars)
- BEND BEND
+ (mkLam tyvars (dict_vars ++ vars) plain_Con)
+ BEND
mk_uf_bits arity
= BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
BEND
where
tyvar_tmpls = take arity alphaTyVars
- (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls)
-
-
-#ifdef DPH
-mkProcessorCon :: Arity -> Id
-mkProcessorCon arity
- = ProcessorCon arity ty
- where
- ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys))
- tycon = mkProcessorTyCon arity
- tyvars = take arity alphaTyVars
- tyvar_tys = map mkTyVarTemplateTy tyvars
-#endif {- Data Parallel Haskell -}
+ (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
+-}
fIRST_TAG :: ConTag
fIRST_TAG = 1 -- Tags allocated from here for real constructors
-
--- given one data constructor in a family, return a list
--- of all the data constructors in that family.
-
-#ifdef DPH
-getDataConFamily :: DataCon -> [DataCon]
-
-getDataConFamily data_con
- = ASSERT(isDataCon data_con)
- getTyConDataCons (getDataConTyCon data_con)
-#endif
\end{code}
\begin{code}
getDataConTag :: DataCon -> ConTag -- will panic if not a DataCon
-
-getDataConTag (Id _ _ _ (DataConId _ tag _ _ _ _)) = tag
-getDataConTag (Id _ _ _ (TupleConId _)) = fIRST_TAG
-getDataConTag (Id _ _ _ (SpecId unspec _ _)) = getDataConTag unspec
-#ifdef DPH
-getDataConTag (ProcessorCon _ _) = fIRST_TAG
-#endif {- Data Parallel Haskell -}
+getDataConTag (Id _ _ (DataConId _ tag _ _ _ _ _) _ _) = tag
+getDataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG
+getDataConTag (Id _ _ (SpecId unspec _ _) _ _) = getDataConTag unspec
getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
+getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
+getDataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a
-getDataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ tycon)) = tycon
-getDataConTyCon (Id _ _ _ (TupleConId a)) = mkTupleTyCon a
-getDataConTyCon (Id _ _ _ (SpecId unspec tys _)) = mkSpecTyCon (getDataConTyCon unspec) tys
-#ifdef DPH
-getDataConTyCon (ProcessorCon a _) = mkProcessorTyCon a
-#endif {- Data Parallel Haskell -}
-
-getDataConSig :: DataCon -> ([TyVarTemplate], ThetaType, [TauType], TyCon)
+getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
-- will panic if not a DataCon
-getDataConSig (Id _ _ _ (DataConId _ _ tyvars theta_ty arg_tys tycon))
+getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
= (tyvars, theta_ty, arg_tys, tycon)
-getDataConSig (Id _ _ _ (TupleConId arity))
+getDataConSig (Id _ _ (TupleConId arity) _ _)
= (tyvars, [], tyvar_tys, mkTupleTyCon arity)
where
tyvars = take arity alphaTyVars
- tyvar_tys = map mkTyVarTemplateTy tyvars
+ tyvar_tys = map mkTyVarTy tyvars
+\end{code}
+
+{- LATER
+getDataConTyCon (Id _ _ _ (SpecId unspec tys _))
+ = mkSpecTyCon (getDataConTyCon unspec) tys
getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
= (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
spec_theta_ty = if null theta_ty then []
else panic "getDataConSig:ThetaTy:SpecDataCon"
spec_tycon = mkSpecTyCon tycon ty_maybes
-
-#ifdef DPH
-getDataConSig (ProcessorCon arity _)
- = (tyvars, [], tyvar_tys, mkProcessorTyCon arity)
- where
- tyvars = take arity alphaTyVars
- tyvar_tys = map mkTyVarTemplateTy tyvars
-#endif {- Data Parallel Haskell -}
+-}
\end{code}
+\begin{pseudocode}
@getInstantiatedDataConSig@ takes a constructor and some types to which
it is applied; it returns its signature instantiated to these types.
\begin{code}
-getInstantiatedDataConSig ::
+getInstantiatedDataConSig ::
DataCon -- The data constructor
-- Not a specialised data constructor
-> [TauType] -- Types to which applied
TauType -- Type of result
)
-getInstantiatedDataConSig data_con tycon_arg_tys
+getInstantiatedDataConSig data_con inst_tys
= ASSERT(isDataCon data_con)
- --false?? WDP 95/06: ASSERT(not (maybeToBool (isSpecId_maybe data_con)))
let
- (tv_tmpls, theta, cmpnt_ty_tmpls, tycon) = getDataConSig data_con
+ (tvs, theta, arg_tys, tycon) = getDataConSig data_con
- inst_env = --ASSERT(length tv_tmpls == length tycon_arg_tys)
-{- if (length tv_tmpls /= length tycon_arg_tys) then
- pprPanic "Id:1666:" (ppCat [ppr PprShowAll data_con, ppr PprDebug tycon_arg_tys])
- else
--} tv_tmpls `zip` tycon_arg_tys
+ inst_env = ASSERT(length tvs == length inst_tys)
+ tvs `zip` inst_tys
- theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ]
- cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls
- result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys)
+ theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
+ cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
+ result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
in
-- Are the first/third results ever used?
(theta_tys, cmpnt_tys, result_ty)
-
-{- UNUSED: allows a specilaised constructor to be instantiated
- (with all argument types of the unspecialsied tycon)
-
-getInstantiatedDataConSig data_con tycon_arg_tys
- = ASSERT(isDataCon data_con)
- if is_speccon && arg_tys_match_error then
- pprPanic "getInstantiatedDataConSig:SpecId:"
- (ppHang (ppr PprDebug data_con) 4 pp_match_error)
- else
- (theta_tys, cmpnt_tys, result_ty) -- Are the first/third results ever used?
- where
- is_speccon = maybeToBool is_speccon_maybe
- is_speccon_maybe = isSpecId_maybe data_con
- Just (unspec_con, spec_tys) = is_speccon_maybe
-
- arg_tys_match_error = maybeToBool match_error_maybe
- match_error_maybe = ASSERT(length spec_tys == length tycon_arg_tys)
- argTysMatchSpecTys spec_tys tycon_arg_tys
- (Just pp_match_error) = match_error_maybe
-
- (tv_tmpls, theta, cmpnt_ty_tmpls, tycon)
- = if is_speccon
- then getDataConSig unspec_con
- else getDataConSig data_con
-
- inst_env = ASSERT(length tv_tmpls == length tycon_arg_tys)
- tv_tmpls `zip` tycon_arg_tys
-
- theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ]
- cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls
- result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys)
--}
-\end{code}
-
-The function @getDataConDeps@ is passed an @Id@ representing a data
-constructor of some type. We look at the source types of the
-constructor and create the set of all @TyCons@ referred to directly
-from the source types.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-getDataConDeps :: Id -> [TyCon]
-
-getDataConDeps (Id _ _ _ (DataConId _ _ _ _ arg_tys _))
- = concat (map getReferredToTyCons arg_tys)
-getDataConDeps (Id _ _ _ (TupleConId _)) = []
-getDataConDeps (Id _ _ _ (SpecId unspec ty_maybes _))
- = getDataConDeps unspec ++ concat (map getReferredToTyCons (catMaybes ty_maybes))
-#ifdef DPH
-getDataConDeps (ProcessorCon _ _) = []
-#endif {- Data Parallel Haskell -}
-#endif {- Semantique strictness analyser -}
\end{code}
Data type declarations are of the form:
For each constructor @Ci@, we want to generate a curried function; so, e.g., for
@C1 x y z@, we want a function binding:
\begin{verbatim}
-fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> CoCon C1 [a, b] [x, y, z]
+fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
\end{verbatim}
-Notice the ``big lambdas'' and type arguments to @CoCon@---we are producing
+Notice the ``big lambdas'' and type arguments to @Con@---we are producing
2nd-order polymorphic lambda calculus with explicit types.
%************************************************************************
present.)
\begin{code}
-getIdUnfolding :: Id -> UnfoldingDetails
+getIdUnfolding :: Id -> UnfoldingDetails
-#ifdef DPH
-getIdUnfolding dcon@(ProcessorCon arity _)
- = let
- (tyvars, dict_vars, vars) = getDataConUnfolding dcon
- tyvar_tys = map mkTyVarTy tyvars
- in
- BIND (CoCon dcon tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
- BIND (mkCoLam vars plain_CoCon) _TO_ lambdized_CoCon ->
- mkUnfoldTemplate (\x->False){-ToDo-} EssentialUnfolding{-ToDo???DPH-} (foldr CoTyLam lambdized_CoCon tyvars)
- BEND BEND
-
--- If we have a PodId whose ``id'' has an unfolding, then we need to
--- parallelize the unfolded expression for the d^th dimension.
-{-
-getIdUnfolding (PodId d _ id)
- = case (unfoldingMaybe (getIdUnfolding id)) of
- Nothing -> noInfo
- Just expr -> trace ("getIdUnfolding ("++
- ppShow 80 (ppr PprDebug id) ++
- ") for " ++ show d ++ "D pod")
- (podizeTemplateExpr d expr)
--}
-#endif {- Data Parallel Haskell -}
-
-getIdUnfolding (Id _ _ id_info _) = getInfo_UF id_info
+getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
+{-LATER:
addIdUnfolding :: Id -> UnfoldingDetails -> Id
addIdUnfolding id@(Id u ty info details) unfold_details
= ASSERT(
_ -> False -- v bad
)
Id u ty (info `addInfo_UF` unfold_details) details
-
-{- UNUSED:
-clearIdUnfolding :: Id -> Id
-clearIdUnfolding (Id u ty info details) = Id u ty (clearInfo_UF info) details
-}
\end{code}
# note local polymorphism...
\end{verbatim}
-For data constructors, we make an unfolding which has a bunch of
-lambdas to bind the arguments, with a (saturated) @CoCon@ inside. In
-the case of overloaded constructors, the dictionaries are just thrown
-away; they were only required in the first place to ensure that the
-type was indeed an instance of the required class.
-\begin{code}
-#ifdef DPH
-getDataConUnfolding :: Id -> ([TyVar], [Id], [Id])
-
-getDataConUnfolding dcon@(ProcessorCon arity _)
- = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
- (tyvars, [], vars)
- BEND
- where
- tyvar_tmpls = take arity alphaTyVars
- (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
%************************************************************************
%* *
\subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
\begin{code}
getIdDemandInfo :: Id -> DemandInfo
-getIdDemandInfo (Id _ _ info _) = getInfo info
+getIdDemandInfo (Id _ _ _ _ info) = getInfo info
addIdDemandInfo :: Id -> DemandInfo -> Id
-addIdDemandInfo (Id u ty info details) demand_info
- = Id u ty (info `addInfo` demand_info) details
+addIdDemandInfo (Id u ty details prags info) demand_info
+ = Id u ty details prags (info `addInfo` demand_info)
\end{code}
\begin{code}
getIdUpdateInfo :: Id -> UpdateInfo
-getIdUpdateInfo (Id u ty info details) = getInfo info
+getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
addIdUpdateInfo :: Id -> UpdateInfo -> Id
-addIdUpdateInfo (Id u ty info details) upd_info
- = Id u ty (info `addInfo` upd_info) details
+addIdUpdateInfo (Id u ty details prags info) upd_info
+ = Id u ty details prags (info `addInfo` upd_info)
\end{code}
\begin{code}
+{- LATER:
getIdArgUsageInfo :: Id -> ArgUsageInfo
getIdArgUsageInfo (Id u ty info details) = getInfo info
addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
addIdArgUsageInfo (Id u ty info details) au_info
= Id u ty (info `addInfo` au_info) details
+-}
\end{code}
\begin{code}
+{- LATER:
getIdFBTypeInfo :: Id -> FBTypeInfo
getIdFBTypeInfo (Id u ty info details) = getInfo info
addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
addIdFBTypeInfo (Id u ty info details) upd_info
= Id u ty (info `addInfo` upd_info) details
+-}
\end{code}
\begin{code}
+{- LATER:
getIdSpecialisation :: Id -> SpecEnv
-getIdSpecialisation (Id _ _ info _) = getInfo info
+getIdSpecialisation (Id _ _ _ _ info) = getInfo info
addIdSpecialisation :: Id -> SpecEnv -> Id
-addIdSpecialisation (Id u ty info details) spec_info
- = Id u ty (info `addInfo` spec_info) details
+addIdSpecialisation (Id u ty details prags info) spec_info
+ = Id u ty details prags (info `addInfo` spec_info)
+-}
\end{code}
Strictness: we snaffle the info out of the IdInfo.
\begin{code}
getIdStrictness :: Id -> StrictnessInfo
-getIdStrictness (Id _ _ id_info _) = getInfo id_info
+getIdStrictness (Id _ _ _ _ info) = getInfo info
addIdStrictness :: Id -> StrictnessInfo -> Id
-addIdStrictness (Id u ty info details) strict_info
- = Id u ty (info `addInfo` strict_info) details
+addIdStrictness (Id u ty details prags info) strict_info
+ = Id u ty details prags (info `addInfo` strict_info)
\end{code}
%************************************************************************
Comparison: equality and ordering---this stuff gets {\em hammered}.
\begin{code}
-cmpId (Id u1 _ _ _) (Id u2 _ _ _) = cmpUnique u1 u2
+cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
-- short and very sweet
\end{code}
\begin{code}
-eqId :: Id -> Id -> Bool
+instance Ord3 (GenId ty) where
+ cmp = cmpId
-eqId a b = case cmpId a b of { EQ_ -> True; _ -> False }
-
-instance Eq Id where
+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 }
-instance Ord Id where
+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 }
-#ifdef __GLASGOW_HASKELL__
_tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
\end{code}
@cmpId_withSpecDataCon@ ensures that any spectys are taken into
account when comparing two data constructors. We need to do this
-because a specialsied data constructor has the same unique as its
-unspeciailsed counterpart.
+because a specialised data constructor has the same Unique as its
+unspecialised counterpart.
\begin{code}
+{-LATER:
cmpId_withSpecDataCon :: Id -> Id -> TAG_
cmpId_withSpecDataCon id1 id2
cmpEqDataCon unspec1 unspec2
= EQ_
-
+-}
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-instance Outputable Id where
+instance Outputable ty => Outputable (GenId ty) where
ppr sty id = pprId sty id
showId :: PprStyle -> Id -> String
-- class and tycon are from PreludeCore [non-std, but convenient]
-- *and* the thing was defined in this module.
-instance_export_flag :: Class -> UniType -> Bool -> ExportFlag
+instance_export_flag :: Class -> Type -> Bool -> ExportFlag
instance_export_flag clas inst_ty from_here
+ = panic "Id:instance_export_flag"
+{-LATER
= if instanceIsExported clas inst_ty from_here
then ExportAll
else NotExported
+-}
\end{code}
Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
PreludeCore''? True if the outermost TyCon is fromPreludeCore.
\begin{code}
-is_prelude_core_ty :: UniType -> Bool
+is_prelude_core_ty :: Type -> Bool
is_prelude_core_ty inst_ty
- = case getUniDataTyCon_maybe inst_ty of
+ = panic "Id.is_prelude_core_ty"
+{- LATER
+ = case maybeDataTyCon inst_ty of
Just (tycon,_,_) -> fromPreludeCore tycon
Nothing -> panic "Id: is_prelude_core_ty"
+-}
\end{code}
Default printing code (not used for interfaces):
\begin{code}
-pprId :: PprStyle -> Id -> Pretty
+pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
pprId other_sty id
= let
pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
- for_code
- = let
+ for_code = panic "pprId: for code"
+ {- = let
pieces_to_print -- maybe use Unique only
= if isSysLocalId id then tail pieces else pieces
in
ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
+ -}
in
case other_sty of
- PprForC _ -> for_code
- PprForAsm _ _ _ -> for_code
- PprInterface _ -> ppPStr occur_name
+ PprForC -> for_code
+ PprForAsm _ _ -> for_code
+ PprInterface -> ppPStr occur_name
PprForUser -> ppPStr occur_name
- PprUnfolding _ -> qualified_name pieces
+ PprUnfolding -> qualified_name pieces
PprDebug -> qualified_name pieces
PprShowAll -> ppBesides [qualified_name pieces,
(ppCat [pp_uniq id,
ppPStr SLIT("{-"),
- ppr other_sty (getIdUniType id),
- ppIdInfo other_sty id True (\x->x) nullIdEnv (getIdInfo id),
+ ppr other_sty (idType id),
+ ppIdInfo other_sty (unsafeGenId2Id id) True
+ (\x->x) nullIdEnv (getIdInfo id),
ppPStr SLIT("-}") ])]
where
occur_name = getOccurrenceName id _APPEND_
( _PK_ (if not (isSysLocalId id)
then ""
- else "." ++ (_UNPK_ (showUnique (getTheUnique id)))))
+ else "." ++ (_UNPK_ (showUnique (getItsUnique id)))))
qualified_name pieces
= ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
- pp_uniq (Id _ _ _ (PreludeId _)) = ppNil -- No uniq to add
- pp_uniq (Id _ _ _ (DataConId _ _ _ _ _ _)) = ppNil -- No uniq to add
- pp_uniq (Id _ _ _ (TupleConId _)) = ppNil -- No uniq to add
- pp_uniq (Id _ _ _ (LocalId _ _)) = ppNil -- uniq printed elsewhere
- pp_uniq (Id _ _ _ (SysLocalId _ _)) = ppNil -- ditto
- pp_uniq (Id _ _ _ (SpecPragmaId _ _ _)) = ppNil -- ditto
- pp_uniq (Id _ _ _ (InstId _)) = ppNil -- ditto
- pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getTheUnique other_id), ppPStr SLIT("-}")]
-
- -- For Robin Popplestone: print PprDebug Ids with # afterwards
- -- if they are of primitive type.
- pp_ubxd pretty = if isPrimType (getIdUniType id)
+ pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
+ pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = ppNil
+ pp_uniq (Id _ _ (TupleConId _) _ _) = ppNil
+ pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
+ pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
+ pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
+ pp_uniq (Id _ _ (InstId _) _ _) = ppNil
+ pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getItsUnique other_id), ppPStr SLIT("-}")]
+
+ -- print PprDebug Ids with # afterwards if they are of primitive type.
+ pp_ubxd pretty = pretty
+
+{- LATER: applying isPrimType restricts type
+ pp_ubxd pretty = if isPrimType (idType id)
then ppBeside pretty (ppChar '#')
else pretty
+-}
+
\end{code}
\begin{code}
-instance NamedThing Id where
- getExportFlag (Id _ _ _ details)
+instance NamedThing (GenId ty) where
+ getExportFlag (Id _ _ details _ _)
= get details
where
- get (DataConId _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
+ get (DataConId _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
get (TupleConId _) = NotExported
get (ImportedId n) = getExportFlag n
get (PreludeId n) = getExportFlag n
get (TopLevId n) = getExportFlag n
get (SuperDictSelId c _) = getExportFlag c
- get (ClassOpId c _) = getExportFlag c
+ get (MethodSelId c _) = getExportFlag c
get (DefaultMethodId c _ _) = getExportFlag c
get (DictFunId c ty from_here _) = instance_export_flag c ty from_here
get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
get (LocalId _ _) = NotExported
get (SysLocalId _ _) = NotExported
get (SpecPragmaId _ _ _) = NotExported
-#ifdef DPH
- get (ProcessorCon _ _) = NotExported
- get (PodId _ _ i) = getExportFlag i
-#endif {- Data Parallel Haskell -}
- isLocallyDefined this_id@(Id _ _ _ details)
+ isLocallyDefined this_id@(Id _ _ details _ _)
= get details
where
- get (DataConId _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
+ get (DataConId _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
get (TupleConId _) = False
get (ImportedId _) = False
get (PreludeId _) = False
get (TopLevId n) = isLocallyDefined n
get (SuperDictSelId c _) = isLocallyDefined c
- get (ClassOpId c _) = isLocallyDefined c
+ get (MethodSelId c _) = isLocallyDefined c
get (DefaultMethodId c _ _) = isLocallyDefined c
get (DictFunId c tyc from_here _) = from_here
-- For DictFunId and ConstMethodId things, you really have to
get (LocalId _ _) = True
get (SysLocalId _ _) = True
get (SpecPragmaId _ _ _) = True
-#ifdef DPH
- get (ProcessorCon _ _) = False
- get (PodId _ _ i) = isLocallyDefined i
-#endif {- Data Parallel Haskell -}
- getOrigName this_id@(Id u _ _ details)
+ getOrigName this_id@(Id u _ details _ _)
= get details
where
- get (DataConId n _ _ _ _ _) = getOrigName n
- get (TupleConId a) = (pRELUDE_BUILTIN, SLIT("Tup") _APPEND_ _PK_ (show a))
- get (ImportedId n) = getOrigName n
- get (PreludeId n) = getOrigName n
- get (TopLevId n) = getOrigName n
+ get (DataConId n _ _ _ _ _ _) = getOrigName n
+ get (TupleConId 0) = (pRELUDE_BUILTIN, SLIT("()"))
+ get (TupleConId a) = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ))
+ get (ImportedId n) = getOrigName n
+ get (PreludeId n) = getOrigName n
+ get (TopLevId n) = getOrigName n
- get (ClassOpId c op) = case (getOrigName c) of -- ToDo; better ???
- (mod, _) -> (mod, getClassOpString op)
+ get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
+ (mod, _) -> (mod, getClassOpString op)
+{- LATER:
get (SpecId unspec ty_maybes _)
= BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
else SLIT(".wrk"))
)
BEND
+-}
- get (InstId inst)
- = (panic "NamedThing.Id.getOrigName (InstId)",
- BIND (getInstNamePieces True inst) _TO_ (piece1:pieces) ->
- BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
- _CONCAT_ (piece1 : dotted_pieces)
- BEND BEND )
-
- get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
- getLocalName n)
- get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
- getLocalName n)
- get (SpecPragmaId n _ _)=(panic "NamedThing.Id.getOrigName (SpecPragmaId)",
- getLocalName n)
-#ifdef DPH
- get (ProcessorCon a _) = ("PreludeBuiltin",
- "MkProcessor" ++ (show a))
- get (PodId d ity id)
- = BIND (getOrigName id) _TO_ (m,n) ->
- (m,n ++ ".mapped.POD"++ show d ++ "." ++ show ity)
- BEND
- -- ToDo(hilly): should the above be using getIdNamePieces???
-#endif {- Data Parallel Haskell -}
+ get (InstId n) = (panic "NamedThing.Id.getOrigName (LocalId)",
+ getLocalName n)
+ get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
+ getLocalName n)
+ get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
+ getLocalName n)
+ get (SpecPragmaId n _ _)= (panic "NamedThing.Id.getOrigName (SpecPragmaId)",
+ getLocalName n)
get other_details
-- the remaining internally-generated flavours of
(_NIL_, _CONCAT_ (piece1 : dotted_pieces))
BEND BEND
- getOccurrenceName this_id@(Id _ _ _ details)
+ getOccurrenceName this_id@(Id _ _ details _ _)
= get details
where
- get (DataConId n _ _ _ _ _) = getOccurrenceName n
- get (TupleConId a) = SLIT("Tup") _APPEND_ (_PK_ (show a))
+ get (DataConId n _ _ _ _ _ _) = getOccurrenceName n
+ get (TupleConId 0) = SLIT("()")
+ get (TupleConId a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
get (ImportedId n) = getOccurrenceName n
get (PreludeId n) = getOccurrenceName n
get (TopLevId n) = getOccurrenceName n
- get (ClassOpId _ op) = getClassOpString op
-#ifdef DPH
- get (ProcessorCon a _) = "MkProcessor" ++ (show a)
- get (PodId _ _ id) = getOccurrenceName id
-#endif {- Data Parallel Haskell -}
+ get (MethodSelId _ op) = getClassOpString op
get _ = snd (getOrigName this_id)
getInformingModules id = panic "getInformingModule:Id"
- getSrcLoc (Id _ _ id_info details)
+ getSrcLoc (Id _ _ details _ id_info)
= get details
where
- get (DataConId n _ _ _ _ _) = getSrcLoc n
+ get (DataConId n _ _ _ _ _ _) = getSrcLoc n
get (TupleConId _) = mkBuiltinSrcLoc
get (ImportedId n) = getSrcLoc n
get (PreludeId n) = getSrcLoc n
get (TopLevId n) = getSrcLoc n
get (SuperDictSelId c _)= getSrcLoc c
- get (ClassOpId c _) = getSrcLoc c
+ get (MethodSelId c _) = getSrcLoc c
get (SpecId unspec _ _) = getSrcLoc unspec
get (WorkerId unwrkr) = getSrcLoc unwrkr
- get (InstId i) = let (loc,_) = getInstOrigin i
- in loc
+ get (InstId n) = getSrcLoc n
get (LocalId n _) = getSrcLoc n
get (SysLocalId n _) = getSrcLoc n
get (SpecPragmaId n _ _)= getSrcLoc n
-#ifdef DPH
- get (ProcessorCon _ _) = mkBuiltinSrcLoc
- get (PodId _ _ n) = getSrcLoc n
-#endif {- Data Parallel Haskell -}
-- well, try the IdInfo
get something_else = getSrcLocIdInfo id_info
- getTheUnique (Id u _ _ _) = u
+ getItsUnique (Id u _ _ _ _) = u
- fromPreludeCore (Id _ _ _ details)
+ fromPreludeCore (Id _ _ details _ _)
= get details
where
- get (DataConId _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
+ get (DataConId _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
get (TupleConId _) = True
get (ImportedId n) = fromPreludeCore n
get (PreludeId n) = fromPreludeCore n
get (TopLevId n) = fromPreludeCore n
get (SuperDictSelId c _) = fromPreludeCore c
- get (ClassOpId c _) = fromPreludeCore c
+ get (MethodSelId c _) = fromPreludeCore c
get (DefaultMethodId c _ _) = fromPreludeCore c
get (DictFunId c t _ _) = fromPreludeCore c && is_prelude_core_ty t
get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
get (SpecId unspec _ _) = fromPreludeCore unspec
get (WorkerId unwrkr) = fromPreludeCore unwrkr
- get (InstId _) = False
+ get (InstId _) = False
get (LocalId _ _) = False
get (SysLocalId _ _) = False
get (SpecPragmaId _ _ _) = False
-#ifdef DPH
- get (ProcessorCon _ _) = True
- get (PodId _ _ id) = fromPreludeCore id
-#endif {- Data Parallel Haskell -}
-
- hasType id = True
- getType id = getIdUniType id
\end{code}
-Reason for @getTheUnique@: The code generator doesn't carry a
+Reason for @getItsUnique@: The code generator doesn't carry a
@UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@
given to it.
+
+%************************************************************************
+%* *
+\subsection{@IdEnv@s and @IdSet@s}
+%* *
+%************************************************************************
+
+\begin{code}
+type IdEnv elt = UniqFM elt
+
+nullIdEnv :: IdEnv a
+
+mkIdEnv :: [(GenId ty, a)] -> IdEnv a
+unitIdEnv :: GenId ty -> a -> IdEnv a
+addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
+growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
+growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
+
+delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
+delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
+combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
+mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
+modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
+rngIdEnv :: IdEnv a -> [a]
+
+isNullIdEnv :: IdEnv a -> Bool
+lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
+lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
+\end{code}
+
+\begin{code}
+addOneToIdEnv = addToUFM
+combineIdEnvs = plusUFM_C
+delManyFromIdEnv = delListFromUFM
+delOneFromIdEnv = delFromUFM
+growIdEnv = plusUFM
+lookupIdEnv = lookupUFM
+mapIdEnv = mapUFM
+mkIdEnv = listToUFM
+nullIdEnv = emptyUFM
+rngIdEnv = eltsUFM
+unitIdEnv = singletonUFM
+
+growIdEnvList env pairs = plusUFM env (listToUFM pairs)
+isNullIdEnv env = sizeUFM env == 0
+lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
+
+-- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
+-- modify function, and put it back.
+
+modifyIdEnv env mangle_fn key
+ = case (lookupIdEnv env key) of
+ Nothing -> env
+ Just xx -> addOneToIdEnv env key (mangle_fn xx)
+\end{code}
+
+\begin{code}
+type GenIdSet ty = UniqSet (GenId ty)
+type IdSet = UniqSet (GenId Type)
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface IdInfo where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import InstEnv(InstTemplate)
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import Outputable(Outputable)
-import PlainCore(PlainCoreAtom(..), PlainCoreExpr(..))
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimOps(PrimOp)
-import SimplEnv(FormSummary, IdVal, InExpr(..), OutAtom(..), OutExpr(..), OutId(..), UnfoldingDetails(..), UnfoldingGuidance(..))
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TaggedCore(SimplifiableBinder(..), SimplifiableCoreExpr(..))
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(UniqSM(..), Unique, UniqueSupply)
-class OptIdInfo a where
- noInfo :: a
- getInfo :: IdInfo -> a
- addInfo :: IdInfo -> a -> IdInfo
- ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
-data ArgUsage = ArgUsage Int | UnknownArgUsage
-data ArgUsageInfo
-type ArgUsageType = [ArgUsage]
-data ArityInfo
-data Bag a
-data BasicLit
-data BinderInfo
-data CoreAtom a
-data CoreExpr a b
-data DeforestInfo = Don'tDeforest | DoDeforest
-data Demand = WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum
-data DemandInfo
-data FBConsum = FBGoodConsum | FBBadConsum
-data FBProd = FBGoodProd | FBBadProd
-data FBType = FBType [FBConsum] FBProd
-data FBTypeInfo
-data Id
-type IdEnv a = UniqFM a
-data IdInfo
-data InstTemplate
-data MagicUnfoldingFun
-data Labda a
-type PlainCoreAtom = CoreAtom Id
-type PlainCoreExpr = CoreExpr Id Id
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data FormSummary
-data IdVal
-type InExpr = CoreExpr (Id, BinderInfo) Id
-type OutAtom = CoreAtom Id
-type OutExpr = CoreExpr Id Id
-type OutId = Id
-data UnfoldingDetails = NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance
-data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int | BadUnfolding
-data SrcLoc
-data Subst
-type SimplifiableBinder = (Id, BinderInfo)
-type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-data SpecEnv
-data SpecInfo = SpecInfo [Labda UniType] Int Id
-data StrictnessInfo = NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id)
-data UniType
-data UniqFM a
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique
-data UniqueSupply
-data UpdateInfo
-type UpdateSpec = [Int]
-addInfo_UF :: IdInfo -> UnfoldingDetails -> IdInfo
-addOneToSpecEnv :: SpecEnv -> SpecInfo -> SpecEnv
-applySubstToIdInfo :: Subst -> IdInfo -> (Subst, IdInfo)
-apply_to_IdInfo :: (UniType -> UniType) -> IdInfo -> IdInfo
-arityMaybe :: ArityInfo -> Labda Int
-boringIdInfo :: IdInfo -> Bool
-bottomIsGuaranteed :: StrictnessInfo -> Bool
-getArgUsage :: ArgUsageInfo -> [ArgUsage]
-getFBType :: FBTypeInfo -> Labda FBType
-getInfo_UF :: IdInfo -> UnfoldingDetails
-getSrcLocIdInfo :: IdInfo -> SrcLoc
-getWorkerId :: StrictnessInfo -> Id
-getWrapperArgTypeCategories :: UniType -> StrictnessInfo -> Labda [Char]
-iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
-indicatesWorker :: [Demand] -> Bool
-lookupConstMethodId :: Id -> UniType -> Labda Id
-lookupSpecEnv :: SpecEnv -> [UniType] -> Labda (Id, [UniType], Int)
-lookupSpecId :: Id -> [Labda UniType] -> Id
-mkArgUsageInfo :: [ArgUsage] -> ArgUsageInfo
-mkArityInfo :: Int -> ArityInfo
-mkBottomStrictnessInfo :: StrictnessInfo
-mkDemandInfo :: Demand -> DemandInfo
-mkFBTypeInfo :: FBType -> FBTypeInfo
-mkMagicUnfolding :: _PackedString -> UnfoldingDetails
-mkSpecEnv :: [SpecInfo] -> SpecEnv
-mkStrictnessInfo :: [Demand] -> Labda Id -> StrictnessInfo
-mkUnfolding :: UnfoldingGuidance -> CoreExpr Id Id -> UnfoldingDetails
-mkUpdateInfo :: [Int] -> UpdateInfo
-noIdInfo :: IdInfo
-noInfo_UF :: UnfoldingDetails
-nonAbsentArgs :: [Demand] -> Int
-nullSpecEnv :: SpecEnv
-ppIdInfo :: PprStyle -> Id -> Bool -> (Id -> Id) -> UniqFM UnfoldingDetails -> IdInfo -> Int -> Bool -> PrettyRep
-unknownArity :: ArityInfo
-updateInfoMaybe :: UpdateInfo -> Labda [Int]
-willBeDemanded :: DemandInfo -> Bool
-workerExists :: StrictnessInfo -> Bool
-wwEnum :: Demand
-wwLazy :: Demand
-wwPrim :: Demand
-wwStrict :: Demand
-wwUnpack :: [Demand] -> Demand
-instance Eq Demand
-instance Eq FBConsum
-instance Eq FBProd
-instance Eq FBType
-instance Eq UpdateInfo
-instance OptIdInfo ArgUsageInfo
-instance OptIdInfo ArityInfo
-instance OptIdInfo DeforestInfo
-instance OptIdInfo DemandInfo
-instance OptIdInfo FBTypeInfo
-instance OptIdInfo SpecEnv
-instance OptIdInfo StrictnessInfo
-instance OptIdInfo UpdateInfo
-instance Ord Demand
-instance Ord UpdateInfo
-instance Outputable Demand
-instance Text Demand
-instance Text UpdateInfo
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}
ppIdInfo,
applySubstToIdInfo, apply_to_IdInfo, -- not for general use, please
- OptIdInfo(..), -- class; for convenience only, really
- -- all the *Infos herein are instances of it
+ OptIdInfo(..), -- class; for convenience only
+ -- all the *Infos herein are instances of it
-- component "id infos"; also abstract:
+ SrcLoc,
+ getSrcLocIdInfo,
+
ArityInfo,
mkArityInfo, unknownArity, arityMaybe,
mkDemandInfo,
willBeDemanded,
- SpecEnv, SpecInfo(..),
- nullSpecEnv, mkSpecEnv, addOneToSpecEnv,
- lookupSpecId, lookupSpecEnv, lookupConstMethodId,
+ MatchEnv, -- the SpecEnv
+ StrictnessInfo(..), -- non-abstract
+ Demand(..), -- non-abstract
- SrcLoc,
- getSrcLocIdInfo,
-
- StrictnessInfo(..), -- non-abstract
- Demand(..), -- non-abstract
wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
---UNUSED: isStrict, absentArg,
indicatesWorker, nonAbsentArgs,
mkStrictnessInfo, mkBottomStrictnessInfo,
getWrapperArgTypeCategories,
workerExists,
bottomIsGuaranteed,
- UnfoldingDetails(..), -- non-abstract! re-exported
- UnfoldingGuidance(..), -- non-abstract; ditto
mkUnfolding,
- iWantToBeINLINEd, mkMagicUnfolding,
noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus
UpdateInfo,
DeforestInfo(..),
- ArgUsageInfo,
+ ArgUsageInfo,
ArgUsage(..),
ArgUsageType(..),
mkArgUsageInfo,
FBConsum(..),
FBProd(..),
mkFBTypeInfo,
- getFBType,
-
- -- and to make the interface self-sufficient...
- Bag, BasicLit, BinderInfo, CoreAtom, CoreExpr, Id,
- IdEnv(..), UniqFM, Unique, IdVal, FormSummary,
- InstTemplate, MagicUnfoldingFun, Maybe, UniType, UniqSM(..),
- SimplifiableBinder(..), SimplifiableCoreExpr(..),
- PlainCoreExpr(..), PlainCoreAtom(..), PprStyle, Pretty(..),
- PrettyRep, UniqueSupply, InExpr(..), OutAtom(..), OutExpr(..),
- OutId(..), Subst
-
- -- and to make sure pragmas work...
- IF_ATTACK_PRAGMAS(COMMA mkUnknownSrcLoc)
+ getFBType
+
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-
-import AbsPrel ( mkFunTy, nilDataCon{-HACK-}
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType
-import Bag ( emptyBag, Bag )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( getIdUniType, getIdInfo,
- getDataConSig, getInstantiatedDataConSig,
- externallyVisibleId, isDataCon,
- unfoldingUnfriendlyId, isWorkerId,
- isWrapperId, DataCon(..)
- IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToId)
- IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
- )
-import IdEnv -- ( nullIdEnv, lookupIdEnv )
-import Inst ( apply_to_Inst, applySubstToInst, Inst )
-import MagicUFs
-import Maybes
-import Outputable
-import PlainCore
+import Ubiq
+
+import 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, mEnvToList )
+import Outputable ( ifPprInterface, Outputable(..){-instances-} )
+import PprStyle ( PprStyle(..) )
import Pretty
-import SimplEnv -- UnfoldingDetails(..), UnfoldingGuidance(..)
-import SrcLoc
-import Subst ( applySubstToTy, Subst )
-import OccurAnal ( occurAnalyseGlobalExpr )
-import TaggedCore -- SimplifiableCore* ...
-import Unique
-import Util
-import WwLib ( mAX_WORKER_ARGS )
+import SrcLoc ( mkUnknownSrcLoc )
+import Type ( eqSimpleTy )
+import Util ( mapAccumL, panic, assertPanic, pprPanic )
+
+applySubstToTy = panic "IdInfo.applySubstToTy"
+isUnboxedDataType = panic "IdInfo.isUnboxedDataType"
+splitTypeWithDictsAsArgs = panic "IdInfo.splitTypeWithDictsAsArgs"
+showTypeCategory = panic "IdInfo.showTypeCategory"
+mkFormSummary = panic "IdInfo.mkFormSummary"
+occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
+isWrapperFor = panic "IdInfo.isWrapperFor"
+pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
\end{code}
An @IdInfo@ gives {\em optional} information about an @Id@. If
DemandInfo -- Whether or not it is definitely
-- demanded
- SpecEnv -- Specialisations of this function which exist
+ (MatchEnv [Type] CoreExpr)
+ -- Specialisations of this function which exist
+ -- This corresponds to a SpecEnv which we do
+ -- not import directly to avoid loop
StrictnessInfo -- Strictness properties, notably
-- how to conjure up "worker" functions
UnfoldingDetails -- Its unfolding; for locally-defined
-- things, this can *only* be NoUnfoldingDetails
- -- or IWantToBeINLINEd (i.e., INLINE pragma).
UpdateInfo -- Which args should be updated
- DeforestInfo -- Whether its definition should be
- -- unfolded during deforestation
+ DeforestInfo -- Whether its definition should be
+ -- unfolded during deforestation
ArgUsageInfo -- how this Id uses its arguments
noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
noInfo noInfo noInfo noInfo mkUnknownSrcLoc
--- "boring" means: nothing to put an interface
+-- "boring" means: nothing to put in interface
boringIdInfo (IdInfo UnknownArity
UnknownDemand
- nullSpecEnv
+ specenv
strictness
unfolding
NoUpdateInfo
Don'tDeforest
_ {- arg_usage: currently no interface effect -}
_ {- no f/b w/w -}
- _ {- src_loc: no effect on interfaces-})
- | boring_strictness strictness
- && boring_unfolding unfolding
+ _ {- src_loc: no effect on interfaces-}
+ )
+ | null (mEnvToList specenv)
+ && boring_strictness strictness
+ && boring_unfolding unfolding
= True
where
boring_strictness NoStrictnessInfo = True
will in turn @apply_to_IdInfo@ of the self-same @IdInfo@. (A very
nasty loop, friends...)
\begin{code}
-apply_to_IdInfo ty_fn
- (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc)
- = let
+apply_to_IdInfo ty_fn (IdInfo arity demand spec strictness unfold
+ update deforest arg_usage fb_ww srcloc)
+ = panic "IdInfo:apply_to_IdInfo"
+{- LATER:
+ let
new_spec = apply_spec spec
- -- NOT a good idea:
+ -- NOT a good idea:
-- apply_strict strictness `thenLft` \ new_strict ->
-- apply_wrap wrap `thenLft` \ new_wrap ->
in
- IdInfo arity demand
- new_spec strictness unfold
+ IdInfo arity demand new_spec strictness unfold
update deforest arg_usage fb_ww srcloc
where
apply_spec (SpecEnv is)
where
apply_to_maybe Nothing = Nothing
apply_to_maybe (Just ty) = Just (ty_fn ty)
+-}
{- NOT a good idea;
apply_strict info@NoStrictnessInfo = returnLft info
Just xx -> applySubstToId subst xx `thenLft` \ new_xx ->
returnLft (Just new_xx)
) `thenLft` \ new_id_maybe ->
- returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
+ returnLft (StrictnessInfo wrap_arg_info new_id_maybe)
-}
\end{code}
Variant of the same thing for the typechecker.
\begin{code}
-applySubstToIdInfo s0
- (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc)
- = case (apply_spec s0 spec) of { (s1, new_spec) ->
+applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
+ update deforest arg_usage fb_ww srcloc)
+ = panic "IdInfo:applySubstToIdInfo"
+{- LATER:
+ case (apply_spec s0 spec) of { (s1, new_spec) ->
(s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) }
where
apply_spec s0 (SpecEnv is)
= case (mapAccumL do_one s0 is) of { (s1, new_is) ->
- (s1, SpecEnv new_is) }
+ (s1, SpecEnv new_is) }
where
do_one s0 (SpecInfo ty_maybes ds spec_id)
= case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) ->
apply_to_maybe s0 (Just ty)
= case (applySubstToTy s0 ty) of { (s1, new_ty) ->
(s1, Just new_ty) }
+-}
\end{code}
\begin{code}
-> Pretty
ppIdInfo sty for_this_id specs_please better_id_fn inline_env
- i@(IdInfo arity demand specialise strictness unfold update deforest arg_usage fbtype srcloc)
+ i@(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype srcloc)
| boringIdInfo i
= ppPStr SLIT("_NI_")
ppInfo sty better_id_fn deforest,
pp_strictness sty (Just for_this_id)
- better_id_fn inline_env strictness,
+ better_id_fn inline_env strictness,
if bottomIsGuaranteed strictness
then pp_NONE
else pp_unfolding sty for_this_id inline_env unfold,
if specs_please
- then pp_specs sty (not (isDataCon for_this_id))
- better_id_fn inline_env specialise
+ then ppSpecs sty (not (isDataCon for_this_id))
+ better_id_fn inline_env (mEnvToList specenv)
else pp_NONE,
-- DemandInfo needn't be printed since it has no effect on interfaces
]
in
case sty of
- PprInterface sw_chker -> if sw_chker OmitInterfacePragmas
- then ppNil
- else stuff
- _ -> stuff
-\end{code}
-
-\begin{code}
-{- OLD:
-pp_info_op :: String -> Pretty -- like pprNonOp
-
-pp_info_op name
- = if isAvarop name || isAconop name
- then ppBesides [ppLparen, ppStr name, ppRparen]
- else ppStr name
--}
+ PprInterface -> if opt_OmitInterfacePragmas
+ then ppNil
+ else stuff
+ _ -> stuff
\end{code}
%************************************************************************
mkDemandInfo demand = DemandedAsPer demand
willBeDemanded :: DemandInfo -> Bool
-willBeDemanded (DemandedAsPer demand) = isStrict demand
+willBeDemanded (DemandedAsPer demand) = isStrict demand
willBeDemanded _ = False
\end{code}
{- DELETED! If this line is in, there is no way to
nuke a DemandInfo, and we have to be able to do that
- when floating let-bindings around
+ when floating let-bindings around
addInfo id_info UnknownDemand = id_info
-}
addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j
- ppInfo (PprInterface _) _ _ = ppNil
+ ppInfo PprInterface _ _ = ppNil
ppInfo sty _ UnknownDemand = ppStr "{-# L #-}"
ppInfo sty _ (DemandedAsPer info)
= ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
%* *
%************************************************************************
-The details of one specialisation, held in an @Id@'s
-@SpecEnv@ are as follows:
-\begin{code}
-data SpecInfo
- = SpecInfo [Maybe UniType] -- Instance types; no free type variables in here
- Int -- No. of dictionaries to eat
- Id -- Specialised version
-\end{code}
-
-For example, if \tr{f} has this @SpecInfo@:
-\begin{verbatim}
- SpecInfo [Just t1, Nothing, Just t3] 2 f'
-\end{verbatim}
-then
-\begin{verbatim}
- f t1 t2 t3 d1 d2 ===> f t2
-\end{verbatim}
-The \tr{Nothings} identify type arguments in which the specialised
-version is polymorphic.
+See SpecEnv.lhs
\begin{code}
-data SpecEnv = SpecEnv [SpecInfo]
-
-mkSpecEnv = SpecEnv
-nullSpecEnv = SpecEnv []
-addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
-
-lookupConstMethodId :: Id -> UniType -> Maybe Id
- -- slight variant on "lookupSpecEnv" below
-
-lookupConstMethodId sel_id spec_ty
- = case (getInfo (getIdInfo sel_id)) of
- SpecEnv spec_infos -> firstJust (map try spec_infos)
- where
- try (SpecInfo (Just ty:nothings) _ const_meth_id)
- = ASSERT(all nothing_is_nothing nothings)
- case (cmpUniType True{-properly-} ty spec_ty) of
- EQ_ -> Just const_meth_id
- _ -> Nothing
-
- nothing_is_nothing Nothing = True -- debugging only
- nothing_is_nothing _ = panic "nothing_is_nothing!"
-
-lookupSpecId :: Id -- *un*specialised Id
- -> [Maybe UniType] -- types to which it is to be specialised
- -> Id -- specialised Id
-
-lookupSpecId unspec_id ty_maybes
- = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
-
- case (firstJust (map try spec_infos)) of
- Just id -> id
- Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id)))
- }
- where
- try (SpecInfo template_maybes _ id)
- | and (zipWith same template_maybes ty_maybes)
- && length template_maybes == length ty_maybes = Just id
- | otherwise = Nothing
-
- same Nothing Nothing = True
- same (Just ty1) (Just ty2) = ty1 == ty2
- same _ _ = False
-
-lookupSpecEnv :: SpecEnv
- -> [UniType]
- -> Maybe (Id,
- [UniType],
- Int)
-
-lookupSpecEnv (SpecEnv []) _ = Nothing -- rather common case
-
-lookupSpecEnv spec_env [] = Nothing -- another common case
-
- -- This can happen even if there is a non-empty spec_env, because
- -- of eta reduction. For example, we might have a defn
- --
- -- f = /\a -> \d -> g a d
- -- which gets transformed to
- -- f = g
- --
- -- Now g isn't applied to any arguments
-
-lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
- = select_match spec_infos
- where
- select_match [] -- no matching spec_infos
- = Nothing
- select_match (SpecInfo ty_maybes toss spec_id : rest)
- = case (match ty_maybes spec_tys) of
- Nothing -> select_match rest
- Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
-
- -- Ambiguity can only arise as a result of specialisations with
- -- an explicit spec_id. The best match is deemed to be the match
- -- with least polymorphism i.e. has the least number of tys left.
- -- This is a non-critical approximation. The only type arguments
- -- where there may be some discretion is for non-overloaded boxed
- -- types. Unboxed types must be matched and we insist that we
- -- always specialise on overloaded types (and discard all the dicts).
-
- select_next best _ toss []
- = case best of
- [match] -> Just match -- Unique best match
- ambig -> pprPanic "Ambiguous Specialisation:\n"
- (ppAboves [ppStr "(check specialisations with explicit spec ids)",
- ppCat (ppStr "between spec ids:" :
- map (ppr PprDebug) [id | (id, _, _) <- ambig]),
- pp_stuff])
-
- select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
- = ASSERT(dnum == toss)
- case (match ty_maybes spec_tys) of
- Nothing -> select_next best tnum dnum rest
- Just tys_left ->
- let tys_len = length tys_left in
- case _tagCmp tnum tys_len of
- _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest -- better match
- _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match
- _GT -> select_next best tnum dnum rest -- worse match
-
-
- match [{-out of templates-}] [] = Just []
-
- match (Nothing:ty_maybes) (spec_ty:spec_tys)
- = case (isUnboxedDataType spec_ty) of
- True -> Nothing -- Can only match boxed type against
- -- type argument which has not been
- -- specialised on
- False -> case match ty_maybes spec_tys of
- Nothing -> Nothing
- Just tys -> Just (spec_ty:tys)
-
- match (Just ty:ty_maybes) (spec_ty:spec_tys)
- = case (cmpUniType True{-properly-} ty spec_ty) of
- EQ_ -> match ty_maybes spec_tys
- other -> Nothing
-
- match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
- -- This is a Real Problem
-
- match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
- -- Partial eta abstraction might make this happen;
- -- meanwhile let's leave in the check
-
- pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
-\end{code}
-
-
-\begin{code}
-instance OptIdInfo SpecEnv where
- noInfo = nullSpecEnv
+instance OptIdInfo (MatchEnv [Type] CoreExpr) where
+ noInfo = nullMEnv
getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
- addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
- = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
- -- We *add* the new specialisation info rather than just replacing it
- -- so that we don't lose old specialisation details.
-
- ppInfo sty better_id_fn spec_env
- = pp_specs sty True better_id_fn nullIdEnv spec_env
-
-pp_specs sty _ _ _ (SpecEnv []) = pp_NONE
-pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
- = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
- ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
- ppInt numds,
- let
- better_spec_id = better_id_fn spec_id
- spec_id_info = getIdInfo better_spec_id
- in
- if not print_spec_ids || boringIdInfo spec_id_info then
- ppNil
- else
- ppCat [ppChar '{',
- ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
- ppChar '}']
- ]
- | (SpecInfo ty_maybes numds spec_id) <- specs ])
- where
- pp_the_list [p] = p
- pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
+ addInfo id_info spec | null (mEnvToList spec) = id_info
+ addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
- pp_maybe Nothing = ifPprInterface sty pp_NONE
- pp_maybe (Just t) = pprParendUniType sty t
+ ppInfo sty better_id_fn spec
+ = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
+
+ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
+ = panic "IdInfo:ppSpecs"
\end{code}
%************************************************************************
bottomIsGuaranteed other = False
getWrapperArgTypeCategories
- :: UniType -- wrapper's type
+ :: Type -- wrapper's type
-> StrictnessInfo -- strictness info about its args
-> Maybe String
isStrict WwEnum = True
isStrict _ = False
-{- UNUSED:
-absentArg :: Demand -> Bool
-
-absentArg (WwLazy absentp) = absentp
-absentArg other = False
--}
-
nonAbsentArgs :: [Demand] -> Int
nonAbsentArgs cmpts
all_present_WwLazies :: [Demand] -> Bool
all_present_WwLazies infos
- = and (map is_L infos)
+ = and (map is_L infos)
where
is_L (WwLazy False) = True -- False <=> "Absent" args do *not* count!
is_L _ = False -- (as they imply a worker)
indicatesWorker :: [Demand] -> Bool
indicatesWorker dems
- = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
+ = fake_mk_ww (_trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems
where
fake_mk_ww _ [] = False
fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
\begin{code}
mkWrapperArgTypeCategories
- :: UniType -- wrapper's type
+ :: Type -- wrapper's type
-> [Demand] -- info about its arguments
- -> String -- a string saying lots about the args
+ -> String -- a string saying lots about the args
mkWrapperArgTypeCategories wrapper_ty wrap_info
= case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) ->
Nothing -> wrapper_args
Just id -> if externallyVisibleId id
&& (unfoldingUnfriendlyId id || not have_wrkr) then
- -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) (
+ -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) $
map un_workerise wrapper_args
- -- )
else
wrapper_args
Nothing -> False
Just id -> isWorkerId id
- am_printing_iface
- = case sty of
- PprInterface _ -> True
- _ -> False
+ am_printing_iface = case sty of { PprInterface -> True ; _ -> False }
pp_basic_info
= ppBesides [ppStr "_S_ \"",
%************************************************************************
\begin{code}
-mkUnfolding :: UnfoldingGuidance -> PlainCoreExpr -> UnfoldingDetails
-iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
-mkMagicUnfolding :: FAST_STRING -> UnfoldingDetails
-
mkUnfolding guide expr
- = GeneralForm False (mkFormSummary NoStrictnessInfo expr)
+ = GenForm False (mkFormSummary NoStrictnessInfo expr)
(BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC)
guide
\end{code}
\begin{code}
-iWantToBeINLINEd guide = IWantToBeINLINEd guide
-
-mkMagicUnfolding tag = MagicForm tag (mkMagicUnfoldingFun tag)
-
-\end{code}
-
-\begin{code}
noInfo_UF = NoUnfoldingDetails
getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
= case unfolding of
- NoUnfoldingDetails -> NoUnfoldingDetails
- GeneralForm _ _ _ BadUnfolding -> NoUnfoldingDetails
- unfold_ok -> unfold_ok
+ 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
-- to strictness constraints in TcPragmas
addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
-addInfo_UF (IdInfo a b d e xxx f g h i j) uf = IdInfo a b d e uf f g h i j
-
+addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
\end{code}
\begin{code}
where
pp NoUnfoldingDetails = pp_NONE
- pp (IWantToBeINLINEd guide) -- not in interfaces
- = if isWrapperId for_this_id
- then pp_NONE -- wrapper: don't complain or mutter
- else ppCat [ppStr "{-IWantToBeINLINEd", ppr sty guide, ppStr "-}", pp_NONE]
-
pp (MagicForm tag _)
= ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
- pp (GeneralForm _ _ _ BadUnfolding) = pp_NONE
+ pp (GenForm _ _ _ BadUnfolding) = pp_NONE
- pp (GeneralForm _ _ template guide)
+ pp (GenForm _ _ template guide)
= let
untagged = unTagBinders template
in
getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest
addInfo id_info Don'tDeforest = id_info
- addInfo (IdInfo a b d e f g _ h i j) deforest =
+ addInfo (IdInfo a b d e f g _ h i j) deforest =
IdInfo a b d e f g deforest h i j
ppInfo sty better_id_fn Don'tDeforest
addInfo id_info NoArgUsageInfo = id_info
addInfo (IdInfo a b d e f g h _ i j) au_info = IdInfo a b d e f g h au_info i j
- ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE
- ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE
+ ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE
+ ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE
ppInfo sty better_id_fn (SomeArgUsageInfo aut)
= ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
ppArgUsage (ArgUsage n) = ppInt n
ppArgUsage (UnknownArgUsage) = ppChar '-'
-ppArgUsageType aut = ppBesides
+ppArgUsageType aut = ppBesides
[ ppChar '"' ,
ppIntersperse ppComma (map ppArgUsage aut),
ppChar '"' ]
addInfo id_info NoFBTypeInfo = id_info
addInfo (IdInfo a b d e f g h i _ j) fb_info = IdInfo a b d e f g h i fb_info j
- ppInfo (PprInterface _) better_id_fn NoFBTypeInfo = ppNil
- ppInfo sty better_id_fn NoFBTypeInfo = ifPprInterface sty pp_NONE
- ppInfo sty better_id_fn (SomeFBTypeInfo (FBType cons prod))
+ ppInfo PprInterface _ NoFBTypeInfo = ppNil
+ ppInfo sty _ NoFBTypeInfo = ifPprInterface sty pp_NONE
+ ppInfo sty _ (SomeFBTypeInfo (FBType cons prod))
= ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)
--ppFBType (FBType n) = ppBesides [ppInt n]
--ppFBType (UnknownFBType) = ppBesides [ppStr "-"]
--
-ppFBType cons prod = ppBesides
+ppFBType cons prod = ppBesides
([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
where
ppCons FBGoodConsum = ppChar 'G'
--- /dev/null
+Breaks the IdInfo/<everything> loops.
+
+\begin{code}
+interface IdLoop where
+
+import PreludePS ( _PackedString )
+import PreludeStdIO ( Maybe )
+
+import BinderInfo ( BinderInfo )
+import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg )
+import CoreUnfold ( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) )
+import CoreUtils ( unTagBinders )
+import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
+ unfoldingUnfriendlyId, getIdInfo,
+ nullIdEnv, lookupIdEnv, IdEnv(..),
+ Id(..), GenId
+ )
+import IdInfo ( IdInfo )
+import Literal ( Literal )
+import MagicUFs ( MagicUnfoldingFun )
+import Outputable ( Outputable(..) )
+import PprStyle ( PprStyle )
+import PprType ( pprParendType )
+import Pretty ( PrettyRep )
+import Type ( GenType )
+import TyVar ( GenTyVar )
+import UniqFM ( UniqFM )
+import Unique ( Unique )
+import Usage ( GenUsage )
+import Util ( Ord3(..) )
+import WwLib ( mAX_WORKER_ARGS )
+
+externallyVisibleId :: Id -> Bool
+isDataCon :: GenId ty -> Bool
+isWorkerId :: GenId ty -> Bool
+isWrapperId :: Id -> Bool
+unfoldingUnfriendlyId :: Id -> Bool
+getIdInfo :: Id -> IdInfo
+nullIdEnv :: UniqFM a
+lookupIdEnv :: UniqFM b -> GenId a -> Maybe b
+mAX_WORKER_ARGS :: Int
+pprParendType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
+unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
+
+type IdEnv a = UniqFM a
+type CoreExpr = GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique))
+ (GenId (GenType (GenTyVar (GenUsage Unique)) Unique))
+ (GenTyVar (GenUsage Unique)) Unique
+
+instance Outputable UnfoldingGuidance
+instance Eq Unique
+instance Outputable Unique
+instance Eq (GenTyVar a)
+instance Ord3 (GenTyVar a)
+instance Outputable (GenTyVar a)
+instance (Outputable a) => Outputable (GenId a)
+instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
+
+data MagicUnfoldingFun
+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
+ | MagicForm _PackedString MagicUnfoldingFun
+
+data UnfoldingGuidance
+ = UnfoldNever
+ | UnfoldAlways
+ | EssentialUnfolding
+ | UnfoldIfGoodArgs Int Int [Bool] Int
+ | BadUnfolding
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[IdUtils]{Constructing PrimOp Ids}
+
+\begin{code}
+#include "HsVersions.h"
+
+module IdUtils ( primOpNameInfo, primOpId ) where
+
+import Ubiq
+import PrelLoop -- here for paranoia checking
+
+import CoreSyn
+import CoreUnfold ( UnfoldingGuidance(..) )
+import Id ( mkPreludeId )
+import IdInfo -- quite a few things
+import Name ( Name(..) )
+import NameTypes ( mkPreludeCoreName )
+import PrelMods ( pRELUDE_BUILTIN )
+import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
+ PrimOpInfo(..), PrimOpResultInfo(..)
+ )
+import Type ( mkForAllTys, mkFunTys, applyTyCon )
+import TysWiredIn ( boolTy )
+import Unique ( mkPrimOpIdUnique )
+import Util ( panic )
+\end{code}
+
+\begin{code}
+primOpNameInfo :: PrimOp -> (FAST_STRING, Name)
+primOpId :: PrimOp -> Id
+
+primOpNameInfo op = (primOp_str op, WiredInVal (primOpId op))
+
+primOpId op
+ = case (primOpInfo op) of
+ Dyadic str ty ->
+ mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
+
+ Monadic str ty ->
+ mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
+
+ Compare str ty ->
+ mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2
+
+ Coerce str ty1 ty2 ->
+ mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1
+
+ PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
+ mk_prim_Id op pRELUDE_BUILTIN str
+ tyvars
+ arg_tys
+ (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
+ (length arg_tys) -- arity
+
+ AlgResult str tyvars arg_tys tycon res_tys ->
+ mk_prim_Id op pRELUDE_BUILTIN str
+ tyvars
+ arg_tys
+ (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
+ (length arg_tys) -- arity
+ where
+ mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
+ = mkPreludeId
+ (mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op)))
+ (mkPreludeCoreName mod name)
+ ty
+ (noIdInfo
+ `addInfo` (mkArityInfo arity)
+ `addInfo_UF` (mkUnfolding EssentialUnfolding
+ (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
+\end{code}
+
+
+\begin{code}
+dyadic_fun_ty ty = mkFunTys [ty, ty] ty
+monadic_fun_ty ty = mkFunTys [ty] ty
+compare_fun_ty ty = mkFunTys [ty, ty] boolTy
+\end{code}
+
+The functions to make common unfoldings are tedious.
+
+\begin{code}
+mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
+
+mk_prim_unfold prim_op tvs arg_tys
+ = panic "IdUtils.mk_prim_unfold"
+{-
+ = let
+ (inst_env, tyvars, tyvar_tys) = instantiateTyVars tvs (map getItsUnique tvs)
+ inst_arg_tys = map (instantiateTauTy inst_env) arg_tys
+ vars = mkTemplateLocals inst_arg_tys
+ in
+ mkLam tyvars vars (Prim prim_op tyvar_tys [VarArg v | v <- vars])
+-}
+\end{code}
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Inst where
-import Class(Class, ClassOp)
-import HsBinds(Binds)
-import HsExpr(ArithSeqInfo, Expr, Qual, RenamedArithSeqInfo(..), RenamedExpr(..))
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(InPat, RenamedPat(..))
-import HsTypes(PolyType)
-import Id(Id)
-import IdInfo(SpecEnv)
-import InstEnv(ClassInstEnv(..), InstTemplate, InstanceMapper(..), MatchEnv(..))
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle, PrettyRep)
-import PrimKind(PrimKind)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique)
-data Class
-data ClassOp
-data ArithSeqInfo a b
-data Expr a b
-data Inst = Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin
-data InstOrigin = OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin
-data OverloadedLit = OverloadedIntegral Integer Id Id | OverloadedFractional (Ratio Integer) Id
-type RenamedArithSeqInfo = ArithSeqInfo Name (InPat Name)
-type RenamedExpr = Expr Name (InPat Name)
-data Literal
-data InPat a
-type RenamedPat = InPat Name
-data Id
-type ClassInstEnv = [(UniType, InstTemplate)]
-data InstTemplate
-type InstanceMapper = Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)
-type MatchEnv a b = [(a, b)]
-data Name
-data PrimKind
-data SrcLoc
-data Subst
-data TyCon
-data TyVar
-data TyVarTemplate
-data UniType
-data Unique
-applySubstToInst :: Subst -> Inst -> (Subst, Inst)
-apply_to_Inst :: (UniType -> UniType) -> Inst -> Inst
-extractConstrainedTyVarsFromInst :: Inst -> [TyVar]
-extractTyVarsFromInst :: Inst -> [TyVar]
-getDictClassAndType :: Inst -> (Class, UniType)
-getInstOrigin :: Inst -> (SrcLoc, PprStyle -> Int -> Bool -> PrettyRep)
-getInstUniType :: Inst -> UniType
-instBindingRequired :: Inst -> Bool
-instCanBeGeneralised :: Inst -> Bool
-isTyVarDict :: Inst -> Bool
-matchesInst :: Inst -> Inst -> Bool
-mkDict :: Unique -> Class -> UniType -> InstOrigin -> Inst
-mkLitInst :: Unique -> OverloadedLit -> UniType -> InstOrigin -> Inst
-mkMethod :: Unique -> Id -> [UniType] -> InstOrigin -> Inst
-instance Outputable Inst
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Inst]{The @Inst@ type: dictionaries or method instances}
-
-\begin{code}
-#include "HsVersions.h"
-
-module Inst (
- Inst(..), InstOrigin(..), OverloadedLit(..),
-
- mkDict, mkMethod, mkLitInst,
- getInstUniType,
---UNUSED: getInstLocalName,
- getInstOrigin, getDictClassAndType,
---UNUSED: instantiateInst,
- applySubstToInst,
- apply_to_Inst, -- not for general use, please
- extractTyVarsFromInst, extractConstrainedTyVarsFromInst,
- matchesInst,
- isTyVarDict,
---UNUSED: isNullaryTyConDict,
- instBindingRequired, instCanBeGeneralised,
-
- -- and to make the interface self-sufficient...
- Class, ClassOp, ArithSeqInfo, RenamedArithSeqInfo(..),
- Literal, InPat, RenamedPat(..), Expr, RenamedExpr(..),
- Id, Name, SrcLoc, Subst, PrimKind,
- TyVar, TyVarTemplate, TyCon, UniType, Unique, InstTemplate,
- InstanceMapper(..), ClassInstEnv(..), MatchEnv(..)
-
- IF_ATTACK_PRAGMAS(COMMA isTyVarTy)
- ) where
-
-import AbsSyn
-import AbsUniType
-import Id ( eqId, applySubstToId,
- getInstNamePieces, getIdUniType,
- Id
- )
-import InstEnv
-import ListSetOps
-import Maybes ( Maybe(..) )
-import Outputable
-import Pretty
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Subst ( applySubstToTy, Subst )
-import Util
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Inst-types]{@Inst@ types}
-%* *
-%************************************************************************
-
-An @Inst@ is either a dictionary, an instance of an overloaded
-literal, or an instance of an overloaded value. We call the latter a
-``method'' even though it may not correspond to a class operation.
-For example, we might have an instance of the @double@ function at
-type Int, represented by
-
- Method 34 doubleId [Int] origin
-
-\begin{code}
-data Inst
- = Dict
- Unique
- Class -- The type of the dict is (c t), where
- UniType -- c is the class and t the unitype;
- InstOrigin
-
- | Method
- Unique
- Id -- (I expect) be a global, local, or ClassOpId.
- -- Inside instance decls (only) it can also be an InstId!
- -- The id needn't be completely polymorphic,
- [UniType] -- The types to which its polymorphic tyvars
- -- should be instantiated
- -- These types may not saturate the Id's foralls.
- InstOrigin
-
- | LitInst
- Unique
- OverloadedLit
- UniType -- the type at which the literal is used
- InstOrigin -- always a literal; but more convenient to carry this around
-
-mkDict = Dict
-mkMethod = Method
-mkLitInst= LitInst
-
-data OverloadedLit
- = OverloadedIntegral Integer -- the number
- Id Id -- cached fromInt, fromInteger
- | OverloadedFractional Rational -- the number
- Id -- cached fromRational
-
-{- UNUSED:
-getInstLocalName (Dict _ clas _ _) = getLocalName clas
-getInstLocalName (Method _ id _ _) = getLocalName id
--}
-
--- this is used for error messages
-getDictClassAndType :: Inst -> (Class, UniType)
-getDictClassAndType (Dict _ clas ty _) = (clas, ty)
-
-getInstUniType :: Inst -> UniType
-getInstUniType (Dict _ clas ty _) = mkDictTy clas ty
-getInstUniType (LitInst _ _ ty _) = ty
-getInstUniType (Method _ id tys _)
- = instantiateTauTy (tyvars `zip` tys) tau_ty
- where
- (tyvars, theta, tau_ty) = splitType (getIdUniType id)
- -- Note that we ignore the overloading; this is
- -- an INSTANCE of an overloaded operation
-\end{code}
-
-@applySubstToInst@ doesn't make any assumptions, but @instantiateInst@
-assumes that the @Id@ in a @Method@ is fully polymorphic (ie has no free
-tyvars)
-
-\begin{code}
-{- UNUSED:
-instantiateInst :: [(TyVarTemplate, UniType)] -> Inst -> Inst
-
-instantiateInst tenv (Dict uniq clas ty orig)
- = Dict uniq clas (instantiateTy tenv ty) orig
-
-instantiateInst tenv (Method uniq id tys orig)
- = --False:ASSERT(idHasNoFreeTyVars id)
- Method uniq id (map (instantiateTy tenv) tys) orig
-
-instantiateInst tenv (LitInst u lit ty orig)
- = LitInst u lit (instantiateTy tenv ty) orig
--}
-
------------------------------------------------------------------
--- too bad we can't use apply_to_Inst
-
-applySubstToInst subst (Dict uniq clas ty orig)
- = case (applySubstToTy subst ty) of { (s2, new_ty) ->
- (s2, Dict uniq clas new_ty orig) }
-
-applySubstToInst subst (Method uniq id tys orig)
- -- NB: *must* zap "id" in the typechecker
- = case (applySubstToId subst id) of { (s2, new_id) ->
- case (mapAccumL applySubstToTy s2 tys) of { (s3, new_tys) ->
- (s3, Method uniq new_id new_tys orig) }}
-
-applySubstToInst subst (LitInst u lit ty orig)
- = case (applySubstToTy subst ty) of { (s2, new_ty) ->
- (s2, LitInst u lit new_ty orig) }
-
------------------------------------------------------------------
-apply_to_Inst :: (UniType -> UniType) -> Inst -> Inst
-
-apply_to_Inst ty_fn (Dict uniq clas ty orig)
- = Dict uniq clas (ty_fn ty) orig
-
-apply_to_Inst ty_fn (Method uniq id tys orig)
- = --FALSE: ASSERT(idHasNoFreeTyVars id)
- Method uniq id (map ty_fn tys) orig
-
-apply_to_Inst ty_fn (LitInst u lit ty orig)
- = LitInst u lit (ty_fn ty) orig
-\end{code}
-
-\begin{code}
-extractTyVarsFromInst, extractConstrainedTyVarsFromInst :: Inst -> [TyVar]
-
-extractTyVarsFromInst (Dict _ _ ty _) = extractTyVarsFromTy ty
-extractTyVarsFromInst (Method _ _ tys _) = extractTyVarsFromTys tys
-extractTyVarsFromInst (LitInst _ _ ty _) = extractTyVarsFromTy ty
-
-extractConstrainedTyVarsFromInst (Dict _ _ ty _) = extractTyVarsFromTy ty
-extractConstrainedTyVarsFromInst (LitInst _ _ ty _) = extractTyVarsFromTy ty
-
--- `Method' is different!
-extractConstrainedTyVarsFromInst (Method _ m tys _)
- = foldr unionLists [] (zipWith xxx tvs tys)
- where
- (tvs,theta,tau_ty) = splitType (getIdUniType m)
-
- constrained_tvs
- = foldr unionLists [] [extractTyVarTemplatesFromTy t | (_,t) <- theta ]
-
- xxx tv ty | tv `elem` constrained_tvs = extractTyVarsFromTy ty
- | otherwise = []
-\end{code}
-
-@matchesInst@ checks when two @Inst@s are instances of the same
-thing at the same type, even if their uniques differ.
-
-\begin{code}
-matchesInst :: Inst -> Inst -> Bool
-matchesInst (Dict _ clas1 ty1 _) (Dict _ clas2 ty2 _)
- = clas1 == clas2 && ty1 == ty2
-matchesInst (Method _ id1 tys1 _) (Method _ id2 tys2 _)
- = id1 `eqId` id2 && tys1 == tys2
-matchesInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _)
- = lit1 `eq` lit2 && ty1 == ty2
- where
- (OverloadedIntegral i1 _ _) `eq` (OverloadedIntegral i2 _ _) = i1 == i2
- (OverloadedFractional f1 _) `eq` (OverloadedFractional f2 _) = f1 == f2
- _ `eq` _ = False
-
-matchesInst other1 other2 = False
-\end{code}
-
-
-\begin{code}
-isTyVarDict :: Inst -> Bool
-isTyVarDict (Dict _ _ ty _) = isTyVarTy ty
-isTyVarDict other = False
-
-{- UNUSED:
-isNullaryTyConDict :: Inst -> Bool
-isNullaryTyConDict (Dict _ _ ty _)
- = case (getUniDataTyCon_maybe ty) of
- Just (tycon, [], _) -> True -- NB null args to tycon
- other -> False
--}
-\end{code}
-
-Two predicates which deal with the case where
-class constraints don't necessarily result in bindings.
-The first tells whether an @Inst@ must be witnessed by an
-actual binding; the second tells whether an @Inst@ can be
-generalised over.
-
-\begin{code}
-instBindingRequired :: Inst -> Bool
-instBindingRequired inst
- = case get_origin_really inst of
- CCallOrigin _ _ _ -> False -- No binding required
- LitLitOrigin _ _ -> False
- other -> True
-
-instCanBeGeneralised :: Inst -> Bool
-instCanBeGeneralised inst
- = case get_origin_really inst of
- CCallOrigin _ _ _ -> False -- Can't be generalised
- LitLitOrigin _ _ -> False -- Can't be generalised
- other -> True
-\end{code}
-
-ToDo: improve these pretty-printing things. The ``origin'' is really only
-relevant in error messages.
-
-\begin{code}
--- ToDo: this instance might be nukable (maybe not: used for error msgs)
-
-instance Outputable Inst where
- ppr PprForUser (LitInst _ lit _ _)
- = case lit of
- OverloadedIntegral i _ _ -> ppInteger i
-#if __GLASGOW_HASKELL__ <= 22
- OverloadedFractional f _ -> ppDouble (fromRational f) -- ToDo: better
-#else
- OverloadedFractional f _ -> ppRational f
-#endif
-
- ppr sty inst
- = ppIntersperse (ppChar '.') (map ppPStr (getInstNamePieces True inst))
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Inst-origin]{The @InstOrigin@ type}
-%* *
-%************************************************************************
-
-The @InstOrigin@ type gives information about where a dictionary came from.
-This is important for decent error message reporting because dictionaries
-don't appear in the original source code. Doubtless this type will evolve...
-
-\begin{code}
-data InstOrigin
- = OccurrenceOf Id -- Occurrence of an overloaded identifier
- SrcLoc
-
- | InstanceDeclOrigin SrcLoc -- Typechecking an instance decl
-
- | LiteralOrigin Literal -- Occurrence of a literal
- SrcLoc -- (now redundant? ToDo)
-
- | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
- SrcLoc
-
- | SignatureOrigin -- A dict created from a type signature
- -- I don't expect this ever to appear in
- -- an error message so I can't be bothered
- -- to give it a source location...
-
- | ClassDeclOrigin SrcLoc -- Manufactured during a class decl
-
- | DerivingOrigin InstanceMapper
- Class
- Bool -- True <=> deriving for *functions*;
- -- do *not* look at the TyCon! [WDP 94/09]
- TyCon
- SrcLoc
-
- -- During "deriving" operations we have an ever changing
- -- mapping of classes to instances, so we record it inside the
- -- origin information. This is a bit of a hack, but it works
- -- fine. (Simon is to blame [WDP].)
-
- | InstanceSpecOrigin InstanceMapper
- Class -- in a SPECIALIZE instance pragma
- UniType
- SrcLoc
-
- -- When specialising instances the instance info attached to
- -- each class is not yet ready, so we record it inside the
- -- origin information. This is a bit of a hack, but it works
- -- fine. (Patrick is to blame [WDP].)
-
- | DefaultDeclOrigin SrcLoc -- Related to a `default' declaration
-
- | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
- SrcLoc
-
- -- Argument or result of a ccall
- -- Dictionaries with this origin aren't actually mentioned in the
- -- translated term, and so need not be bound. Nor should they
- -- be abstracted over.
- | CCallOrigin SrcLoc
- String -- CCall label
- (Maybe RenamedExpr) -- Nothing if it's the result
- -- Just arg, for an argument
-
- | LitLitOrigin SrcLoc
- String -- the litlit
-
- | UnknownOrigin -- Help! I give up...
-\end{code}
-
-\begin{code}
-get_origin_really (Dict u clas ty origin) = origin
-get_origin_really (Method u clas ty origin) = origin
-get_origin_really (LitInst u lit ty origin) = origin
-
-getInstOrigin inst
- = let origin = get_origin_really inst
- in get_orig origin
- where
- get_orig :: InstOrigin -> (SrcLoc, PprStyle -> Pretty)
-
- get_orig (OccurrenceOf id loc)
- = (loc, \ sty -> ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
- ppr sty id, ppChar '\''])
- get_orig (InstanceDeclOrigin loc)
- = (loc, \ sty -> ppStr "in an instance declaration")
- get_orig (LiteralOrigin lit loc)
- = (loc, \ sty -> ppCat [ppStr "at an overloaded literal:", ppr sty lit])
- get_orig (ArithSeqOrigin seq loc)
- = (loc, \ sty -> ppCat [ppStr "at an arithmetic sequence:", ppr sty seq])
- get_orig SignatureOrigin
- = (mkUnknownSrcLoc, \ sty -> ppStr "in a type signature")
- get_orig (ClassDeclOrigin loc)
- = (loc, \ sty -> ppStr "in a class declaration")
- get_orig (DerivingOrigin _ clas is_function tycon loc)
- = (loc, \ sty -> ppBesides [ppStr "in a `deriving' clause; class \"",
- ppr sty clas,
- if is_function
- then ppStr "\"; type: functions"
- else ppBeside (ppStr "\"; offending type \"") (ppr sty tycon),
- ppStr "\""])
- get_orig (InstanceSpecOrigin _ clas ty loc)
- = (loc, \ sty -> ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
- ppr sty clas, ppStr "\" type: ", ppr sty ty])
- get_orig (DefaultDeclOrigin loc)
- = (loc, \ sty -> ppStr "in a `default' declaration")
- get_orig (ValSpecOrigin name loc)
- = (loc, \ sty -> ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
- ppr sty name, ppStr "'"])
- get_orig (CCallOrigin loc clabel Nothing{-ccall result-})
- = (loc, \ sty -> ppBesides [ppStr "in the result of the _ccall_ to `",
- ppStr clabel, ppStr "'"])
- get_orig (CCallOrigin loc clabel (Just arg_expr))
- = (loc, \ sty -> ppBesides [ppStr "in an argument in the _ccall_ to `",
- ppStr clabel, ppStr "', namely: ", ppr sty arg_expr])
- get_orig (LitLitOrigin loc s)
- = (loc, \ sty -> ppBesides [ppStr "in this ``literal-literal'': ", ppStr s])
- get_orig UnknownOrigin
- = (mkUnknownSrcLoc, \ sty -> ppStr "in... oops -- I don't know where the overloading came from!")
-\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
%
-\section[BasicLit]{@BasicLit@: Machine literals (unboxed, of course)}
+\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
\begin{code}
#include "HsVersions.h"
-module BasicLit (
- BasicLit(..),
+module Literal (
+ Literal(..),
+
mkMachInt, mkMachWord,
- typeOfBasicLit, kindOfBasicLit,
- showBasicLit,
- isNoRepLit, isLitLitLit,
+ literalType, literalPrimRep,
+ showLiteral,
+ isNoRepLit, isLitLitLit
-- and to make the interface self-sufficient....
- UniType, PrimKind
) where
-import AbsPrel ( addrPrimTy, intPrimTy, floatPrimTy, doublePrimTy,
- charPrimTy, wordPrimTy,
- integerTy, rationalTy, stringTy, UniType,
- TauType(..)
- IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType ( TyCon IF_ATTACK_PRAGMAS(COMMA cmpTyCon) )
-import PrimKind ( getKindInfo ) -- ToDo: *** HACK import ****
-import CLabelInfo ( stringToC, charToC, charToEasyHaskell )
-import Outputable -- class for printing, forcing
+import Ubiq{-uitous-}
+
+-- friends:
+import PrimRep ( PrimRep(..) ) -- non-abstract
+import TysPrim ( getPrimRepInfo,
+ addrPrimTy, intPrimTy, floatPrimTy,
+ doublePrimTy, charPrimTy, wordPrimTy )
+
+-- others:
+import CStrings ( stringToC, charToC, charToEasyHaskell )
+import TysWiredIn ( integerTy, rationalTy, stringTy )
import Pretty -- pretty-printing stuff
-import PrimKind ( PrimKind(..) )
-import Util
+import PprStyle ( PprStyle(..), codeStyle )
+import Util ( panic )
\end{code}
-So-called @BasicLits@ are {\em either}:
+So-called @Literals@ are {\em either}:
\begin{itemize}
\item
An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
\end{itemize}
\begin{code}
-data BasicLit
+data Literal
= MachChar Char
| MachStr FAST_STRING
| MachAddr Integer -- whatever this machine thinks is a "pointer"
| MachInt Integer -- for the numeric types, these are
- Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
+ Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
| MachFloat Rational
| MachDouble Rational
| MachLitLit FAST_STRING
- PrimKind
+ PrimRep
| NoRepStr FAST_STRING -- the uncommitted ones
| NoRepInteger Integer
deriving (Eq, Ord)
-- The Ord is needed for the FiniteMap used in the lookForConstructor
-- in SimplEnv. If you declared that lookForConstructor *ignores*
- -- constructor-applications with CoLitAtom args, then you could get
+ -- constructor-applications with LitArg args, then you could get
-- rid of this Ord.
-mkMachInt, mkMachWord :: Integer -> BasicLit
+mkMachInt, mkMachWord :: Integer -> Literal
mkMachInt x = MachInt x True{-signed-}
mkMachWord x = MachInt x False{-unsigned-}
\end{code}
\begin{code}
-typeOfBasicLit :: BasicLit -> UniType
-
-typeOfBasicLit (MachChar _) = charPrimTy
-typeOfBasicLit (MachStr _) = addrPrimTy
-typeOfBasicLit (MachAddr _) = addrPrimTy
-typeOfBasicLit (MachInt _ signed) = if signed then intPrimTy else wordPrimTy
-typeOfBasicLit (MachFloat _) = floatPrimTy
-typeOfBasicLit (MachDouble _) = doublePrimTy
-typeOfBasicLit (MachLitLit _ k) = case (getKindInfo k) of { (_,t,_) -> t }
-typeOfBasicLit (NoRepInteger _) = integerTy
-typeOfBasicLit (NoRepRational _)= rationalTy
-typeOfBasicLit (NoRepStr _) = stringTy
+literalType :: Literal -> Type
+
+literalType (MachChar _) = charPrimTy
+literalType (MachStr _) = addrPrimTy
+literalType (MachAddr _) = addrPrimTy
+literalType (MachInt _ signed) = if signed then intPrimTy else wordPrimTy
+literalType (MachFloat _) = floatPrimTy
+literalType (MachDouble _) = doublePrimTy
+literalType (MachLitLit _ k) = case (getPrimRepInfo k) of { (_,t,_) -> t }
+literalType (NoRepInteger _) = integerTy
+literalType (NoRepRational _)= rationalTy
+literalType (NoRepStr _) = stringTy
\end{code}
\begin{code}
-kindOfBasicLit :: BasicLit -> PrimKind
-
-kindOfBasicLit (MachChar _) = CharKind
-kindOfBasicLit (MachStr _) = AddrKind -- specifically: "char *"
-kindOfBasicLit (MachAddr _) = AddrKind
-kindOfBasicLit (MachInt _ signed) = if signed then IntKind else WordKind
-kindOfBasicLit (MachFloat _) = FloatKind
-kindOfBasicLit (MachDouble _) = DoubleKind
-kindOfBasicLit (MachLitLit _ k) = k
-kindOfBasicLit (NoRepInteger _) = panic "kindOfBasicLit:NoRepInteger"
-kindOfBasicLit (NoRepRational _)= panic "kindOfBasicLit:NoRepRational"
-kindOfBasicLit (NoRepStr _) = panic "kindOfBasicLit:NoRepString"
+literalPrimRep :: Literal -> PrimRep
+
+literalPrimRep (MachChar _) = CharRep
+literalPrimRep (MachStr _) = AddrRep -- specifically: "char *"
+literalPrimRep (MachAddr _) = AddrRep
+literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep
+literalPrimRep (MachFloat _) = FloatRep
+literalPrimRep (MachDouble _) = DoubleRep
+literalPrimRep (MachLitLit _ k) = k
+#ifdef DEBUG
+literalPrimRep (NoRepInteger _) = panic "literalPrimRep:NoRepInteger"
+literalPrimRep (NoRepRational _)= panic "literalPrimRep:NoRepRational"
+literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString"
+#endif
\end{code}
The boring old output stuff:
\begin{code}
ppCast :: PprStyle -> FAST_STRING -> Pretty
-ppCast (PprForC _) cast = ppPStr cast
-ppCast _ _ = ppNil
+ppCast PprForC cast = ppPStr cast
+ppCast _ _ = ppNil
-instance Outputable BasicLit where
+instance Outputable Literal where
ppr sty (MachChar ch)
= let
char_encoding
= case sty of
- PprForC _ -> charToC ch
- PprForAsm _ _ _ -> charToC ch
- PprUnfolding _ -> charToEasyHaskell ch
- _ -> [ch]
+ PprForC -> charToC ch
+ PprForAsm _ _ -> charToC ch
+ PprUnfolding -> charToEasyHaskell ch
+ _ -> [ch]
in
ppBeside (ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\''])
(if_ubxd sty)
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]
-#ifdef DPH
- -- I know that this thing shouldnt pop out of the compiler, but the
- -- native code generator tries to generate code to initilialise a closure
- -- with this value... (in glaExts/PreludeGlaInOut.lhs)
- ppr sty MachVoid = ppStr "0 ! {- void# -}"
-#endif {- Data Parallel Haskell -}
-
ppr sty (NoRepInteger i)
| codeStyle sty = ppInteger i
| ufStyle sty = ppCat [ppStr "_NOREP_I_", ppInteger i]
| ufStyle sty = ppBesides [ppStr "``", ppPStr s, ppStr "'' _K_ ", ppr sty k]
| otherwise = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
-ufStyle (PprUnfolding _) = True
-ufStyle _ = False
+ufStyle PprUnfolding = True
+ufStyle _ = False
if_ubxd sty = if codeStyle sty then ppNil else ppChar '#'
-showBasicLit :: PprStyle -> BasicLit -> String
+showLiteral :: PprStyle -> Literal -> String
-showBasicLit sty lit = ppShow 80 (ppr sty lit)
+showLiteral sty lit = ppShow 80 (ppr sty lit)
\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[Name]{@Name@: to transmit name info from renamer to typechecker}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Name (
+ -- things for the Name NON-abstract type
+ Name(..),
+
+ isTyConName, isClassName, isClassOpName,
+ isUnboundName, invisibleName,
+
+ getTagFromClassOpName, getSynNameArity,
+
+ getNameShortName, getNameFullName
+
+ ) where
+
+import Ubiq{-uitous-}
+
+import NameLoop -- break Name/Id loop, Name/PprType/Id loop
+
+import NameTypes
+import Outputable ( ExportFlag(..) )
+import Pretty
+import PprStyle ( PprStyle(..) )
+import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
+import TyCon ( TyCon, getSynTyConArity )
+import TyVar ( GenTyVar )
+import Unique ( pprUnique, Unique )
+import Util ( panic, panic#, pprPanic )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Name-datatype]{The @Name@ datatype}
+%* *
+%************************************************************************
+
+\begin{code}
+data Name
+ = Short Unique -- Local ids and type variables
+ ShortName
+
+ -- Nano-prelude things; truly wired in.
+ -- Includes all type constructors and their associated data constructors
+ | WiredInTyCon TyCon
+ | WiredInVal Id
+
+ | TyConName Unique -- TyCons other than Prelude ones; need to
+ FullName -- separate these because we want to pin on
+ Arity -- their arity.
+ Bool -- False <=> `type',
+ -- True <=> `data' or `newtype'
+ [Name] -- List of user-visible data constructors;
+ -- NB: for `data' types only.
+ -- Used in checking import/export lists.
+
+ | ClassName Unique
+ FullName
+ [Name] -- List of class methods; used for checking
+ -- import/export lists.
+
+ | ValName Unique -- Top level id
+ FullName
+
+ | ClassOpName Unique
+ Name -- Name associated w/ the defined class
+ -- (can get unique and export info, etc., from this)
+ FAST_STRING -- The class operation
+ Int -- Unique tag within the class
+
+ -- Miscellaneous
+ | Unbound FAST_STRING -- Placeholder for a name which isn't in scope
+ -- Used only so that the renamer can carry on after
+ -- finding an unbound identifier.
+ -- The string is grabbed from the unbound name, for
+ -- debugging information only.
+\end{code}
+
+These @is..@ functions are used in the renamer to check that (eg) a tycon
+is seen in a context which demands one.
+
+\begin{code}
+isTyConName, isClassName, isUnboundName :: Name -> Bool
+
+isTyConName (TyConName _ _ _ _ _) = True
+isTyConName (WiredInTyCon _) = True
+isTyConName other = False
+
+isClassName (ClassName _ _ _) = True
+isClassName other = False
+
+isUnboundName (Unbound _) = True
+isUnboundName other = False
+\end{code}
+
+@isClassOpName@ is a little cleverer: it checks to see whether the
+class op comes from the correct class.
+
+\begin{code}
+isClassOpName :: Name -- The name of the class expected for this op
+ -> Name -- The name of the thing which should be a class op
+ -> Bool
+
+isClassOpName (ClassName uniq1 _ _) (ClassOpName _ (ClassName uniq2 _ _) _ _)
+ = uniq1 == uniq2
+isClassOpName other_class other_op = False
+\end{code}
+
+A Name is ``invisible'' if the user has no business seeing it; e.g., a
+data-constructor for an abstract data type (but whose constructors are
+known because of a pragma).
+\begin{code}
+invisibleName :: Name -> Bool
+
+invisibleName (TyConName _ n _ _ _) = invisibleFullName n
+invisibleName (ClassName _ n _) = invisibleFullName n
+invisibleName (ValName _ n) = invisibleFullName n
+invisibleName _ = False
+\end{code}
+
+\begin{code}
+getTagFromClassOpName :: Name -> Int
+getTagFromClassOpName (ClassOpName _ _ _ tag) = tag
+
+getSynNameArity :: Name -> Maybe Arity
+getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity
+getSynNameArity (WiredInTyCon tycon) = getSynTyConArity tycon
+getSynNameArity other_name = Nothing
+
+getNameShortName :: Name -> ShortName
+getNameShortName (Short _ sn) = sn
+
+getNameFullName :: Name -> FullName
+getNameFullName n = get_nm "getNameFullName" n
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Name-instances]{Instance declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+cmpName n1 n2 = c n1 n2
+ where
+ c (Short u1 _) (Short u2 _) = cmp u1 u2
+
+ c (WiredInTyCon tc1) (WiredInTyCon tc2) = cmp tc1 tc2
+ c (WiredInVal id1) (WiredInVal id2) = cmp id1 id2
+
+ c (TyConName u1 _ _ _ _) (TyConName u2 _ _ _ _) = cmp u1 u2
+ c (ClassName u1 _ _) (ClassName u2 _ _) = cmp u1 u2
+ c (ValName u1 _) (ValName u2 _) = cmp u1 u2
+
+ c (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _) = cmp u1 u2
+ c (Unbound a) (Unbound b) = panic# "Eq.Name.Unbound"
+
+ c other_1 other_2 -- the tags *must* be different
+ = let tag1 = tag_Name n1
+ tag2 = tag_Name n2
+ in
+ if tag1 _LT_ tag2 then LT_ else GT_
+
+ tag_Name (Short _ _) = (ILIT(1) :: FAST_INT)
+ tag_Name (WiredInTyCon _) = ILIT(2)
+ tag_Name (WiredInVal _) = ILIT(3)
+ tag_Name (TyConName _ _ _ _ _) = ILIT(7)
+ tag_Name (ClassName _ _ _) = ILIT(8)
+ tag_Name (ValName _ _) = ILIT(9)
+ tag_Name (ClassOpName _ _ _ _) = ILIT(10)
+ tag_Name (Unbound _) = ILIT(11)
+\end{code}
+
+\begin{code}
+instance Eq Name where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord Name 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 }
+
+instance Ord3 Name where
+ cmp = cmpName
+\end{code}
+
+\begin{code}
+instance NamedThing Name where
+ getExportFlag (Short _ _) = NotExported
+ getExportFlag (WiredInTyCon _) = NotExported -- compiler always know about these
+ getExportFlag (WiredInVal _) = NotExported
+ getExportFlag (ClassOpName _ c _ _) = getExportFlag c
+ getExportFlag other = getExportFlag (get_nm "getExportFlag" other)
+
+ isLocallyDefined (Short _ _) = True
+ isLocallyDefined (WiredInTyCon _) = False
+ isLocallyDefined (WiredInVal _) = False
+ isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c
+ isLocallyDefined other = isLocallyDefined (get_nm "isLocallyDefined" other)
+
+ getOrigName (Short _ sn) = getOrigName sn
+ getOrigName (WiredInTyCon tc) = getOrigName tc
+ getOrigName (WiredInVal id) = getOrigName id
+ getOrigName (ClassOpName _ c op _) = (fst (getOrigName c), op)
+ getOrigName other = getOrigName (get_nm "getOrigName" other)
+
+ getOccurrenceName (Short _ sn) = getOccurrenceName sn
+ getOccurrenceName (WiredInTyCon tc) = getOccurrenceName tc
+ getOccurrenceName (WiredInVal id) = getOccurrenceName id
+ getOccurrenceName (ClassOpName _ _ op _) = op
+ getOccurrenceName (Unbound s) = s _APPEND_ SLIT("<unbound>")
+ getOccurrenceName other = getOccurrenceName (get_nm "getOccurrenceName" other)
+
+ getInformingModules thing = panic "getInformingModule:Name"
+
+ getSrcLoc (Short _ sn) = getSrcLoc sn
+ getSrcLoc (WiredInTyCon tc) = mkBuiltinSrcLoc
+ getSrcLoc (WiredInVal id) = mkBuiltinSrcLoc
+ getSrcLoc (ClassOpName _ c _ _) = getSrcLoc c
+ getSrcLoc (Unbound _) = mkUnknownSrcLoc
+ getSrcLoc other = getSrcLoc (get_nm "getSrcLoc" other)
+
+ getItsUnique (Short u _) = u
+ getItsUnique (WiredInTyCon t) = getItsUnique t
+ getItsUnique (WiredInVal i) = getItsUnique i
+ getItsUnique (TyConName u _ _ _ _) = u
+ getItsUnique (ClassName u _ _) = u
+ getItsUnique (ValName u _) = u
+ getItsUnique (ClassOpName u _ _ _) = u
+
+ fromPreludeCore (WiredInTyCon _) = True
+ fromPreludeCore (WiredInVal _) = True
+ fromPreludeCore (ClassOpName _ c _ _) = fromPreludeCore c
+ fromPreludeCore other = False
+\end{code}
+
+A useful utility; most emphatically not for export! (but see
+@getNameFullName@...):
+\begin{code}
+get_nm :: String -> Name -> FullName
+
+get_nm msg (TyConName _ n _ _ _) = n
+get_nm msg (ClassName _ n _) = n
+get_nm msg (ValName _ n) = n
+#ifdef DEBUG
+get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other)
+-- If match failure, probably on a ClassOpName or Unbound :-(
+#endif
+\end{code}
+
+\begin{code}
+instance Outputable Name where
+#ifdef DEBUG
+ ppr PprDebug (Short u s) = pp_debug u s
+
+ ppr PprDebug (TyConName u n _ _ _) = pp_debug u n
+ ppr PprDebug (ClassName u n _) = pp_debug u n
+ ppr PprDebug (ValName u n) = pp_debug u n
+#endif
+ ppr sty (Short u s) = ppr sty s
+
+ ppr sty (WiredInTyCon tc) = ppr sty tc
+ ppr sty (WiredInVal id) = ppr sty id
+
+ ppr sty (TyConName u n a b c) = ppr sty n
+ ppr sty (ClassName u n c) = ppr sty n
+ ppr sty (ValName u n) = ppr sty n
+
+ ppr sty (ClassOpName u c s i)
+ = let
+ ps = ppPStr s
+ in
+ case sty of
+ PprForUser -> ps
+ PprInterface -> ps
+ PprDebug -> ps
+ other -> ppBesides [ps, ppChar '{',
+ ppSep [pprUnique u,
+ ppStr "op", ppInt i,
+ ppStr "cls", ppr sty c],
+ ppChar '}']
+
+ ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
+
+pp_debug uniq thing
+ = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
+\end{code}
--- /dev/null
+Breaks the Name/Id loop, and the Name/Id/PprType loop.
+
+\begin{code}
+interface NameLoop where
+
+import Id ( GenId )
+import Outputable ( NamedThing, Outputable )
+import TyCon ( TyCon )
+import Type ( GenType )
+import TyVar ( GenTyVar )
+import Util ( Ord3(..) )
+
+instance NamedThing (GenId a)
+instance Ord3 (GenId a)
+instance (Outputable a) => Outputable (GenId a)
+
+instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
+instance Outputable (GenTyVar a)
+instance Outputable TyCon
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface NameTypes where
-import Outputable(ExportFlag, NamedThing, Outputable)
-import PreludePS(_PackedString)
-import SrcLoc(SrcLoc)
-import Unique(Unique)
-data ExportFlag
-data FullName
-data Provenance = ThisModule | InventedInThisModule | ExportedByPreludeCore | OtherPrelude _PackedString | OtherModule _PackedString [_PackedString] | HereInPreludeCore | OtherInstance _PackedString [_PackedString]
-data ShortName
-data SrcLoc
-data Unique
-fromPrelude :: _PackedString -> Bool
-invisibleFullName :: FullName -> Bool
-mkFullName :: _PackedString -> _PackedString -> Provenance -> ExportFlag -> SrcLoc -> FullName
-mkPreludeCoreName :: _PackedString -> _PackedString -> FullName
-mkPrivateFullName :: _PackedString -> _PackedString -> Provenance -> ExportFlag -> SrcLoc -> FullName
-mkShortName :: _PackedString -> SrcLoc -> ShortName
-unlocaliseFullName :: FullName -> FullName
-unlocaliseShortName :: _PackedString -> Unique -> ShortName -> FullName
-instance NamedThing FullName
-instance NamedThing ShortName
-instance Outputable FullName
-instance Outputable ShortName
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
unlocaliseFullName, unlocaliseShortName,
-#ifdef DPH
- isInventedFullName,
-#endif {- Data Parallel Haskell -}
-
-- and to make the interface self-sufficient....
ExportFlag, Unique, SrcLoc
) where
-import CLabelInfo ( identToC, cSEP )
+CHK_Ubiq() -- debugging consistency check
+import PrelLoop -- for paranoia checking
+
+import PrelMods ( pRELUDE, pRELUDE_CORE ) -- NB: naughty import
+
+import CStrings ( identToC, cSEP )
import Outputable
-import PrelFuns ( pRELUDE, pRELUDE_CORE ) -- NB: naughty import
import Pretty
+import PprStyle ( PprStyle(..), codeStyle )
+
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import Unique ( showUnique, Unique )
import Util
\end{code}
\begin{code}
-#ifdef DPH
-isInventedFullName (FullName _ _ p _ _ _)
- = case p of
- InventedInThisModule -> True
- _ -> False
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
unlocaliseShortName :: FAST_STRING -> Unique -> ShortName -> FullName
{- We now elucidate Simon's favourite piece of code:
getSrcLoc (ShortName s l) = l
fromPreludeCore _ = False
#ifdef DEBUG
- getTheUnique (ShortName s l) = panic "NamedThing.ShortName.getTheUnique"
+ getItsUnique (ShortName s l) = panic "NamedThing.ShortName.getItsUnique"
getInformingModules a = panic "NamedThing.ShortName.getInformingModule"
- hasType a = panic "NamedThing.ShortName.hasType"
- getType a = panic "NamedThing.ShortName.getType"
#endif
\end{code}
OtherPrelude _ -> [pRELUDE]
#ifdef DEBUG
- getTheUnique = panic "NamedThing.FullName.getTheUnique"
- hasType = panic "NamedThing.FullName.hasType"
- getType = panic "NamedThing.FullName.getType"
+ getItsUnique = panic "NamedThing.FullName.getItsUnique"
#endif
\end{code}
else case sty of
PprForUser -> ppNil
PprDebug -> ppNil
- PprInterface _ -> ppNil
- PprUnfolding _ -> ppNil -- ToDo: something diff later?
- PprForC _ -> ppBeside (identToC m) (ppPStr cSEP)
- PprForAsm _ False _ -> ppBeside (identToC m) (ppPStr cSEP)
- PprForAsm _ True _ -> ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
+ PprInterface -> ppNil
+ PprUnfolding -> ppNil -- ToDo: something diff later?
+ PprForC -> ppBeside (identToC m) (ppPStr cSEP)
+ PprForAsm False _ -> ppBeside (identToC m) (ppPStr cSEP)
+ PprForAsm True _ -> ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
_ -> ppBeside (ppPStr m) (ppChar '.'))
(if codeStyle sty
- then identToC s
+ then identToC s
else case sty of
- PprInterface _ -> pp_local_name s p
- PprForUser -> pp_local_name s p
- _ -> ppPStr s)
+ PprInterface -> pp_local_name s p
+ PprForUser -> pp_local_name s p
+ _ -> ppPStr s)
pp_debug = ppBeside pp_name (pp_occur_name s p)
in
- case sty of
- PprShowAll -> ppBesides [pp_debug, pp_exp e] -- (ppr sty loc)
- PprDebug -> pp_debug
- PprUnfolding _ -> pp_debug
- _ -> pp_name
+ case sty of
+ PprShowAll -> ppBesides [pp_debug, pp_exp e] -- (ppr sty loc)
+ PprDebug -> pp_debug
+ PprUnfolding -> pp_debug
+ _ -> pp_name
where
pp_exp NotExported = ppNil
pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface OrdList where
-data OrdList a
-flattenOrdList :: OrdList a -> [a]
-mkEmptyList :: OrdList a
-mkParList :: OrdList a -> OrdList a -> OrdList a
-mkSeqList :: OrdList a -> OrdList a -> OrdList a
-mkUnitList :: a -> OrdList a
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1994
-%
-
-%
-% This is useful, general stuff for the Native Code Generator.
-%
-
-\begin{code}
-
-module OrdList (
- OrdList,
-
- mkParList, mkSeqList, mkEmptyList, mkUnitList,
-
- flattenOrdList
--- UNUSED:
--- concatOrdList, fnOrdList, foldOrdList,
--- mapAccumBOrdList, mapAccumLOrdList, mapAccumROrdList,
--- mapOrdList, reverseOrdList, simplOrdList
- ) where
-
-import Util ( mapAccumB, mapAccumL, mapAccumR )
-
-\end{code}
-
-This section provides an ordering list that allows fine grain
-parallelism to be expressed. This is used (ultimately) for scheduling
-of assembly language instructions.
-
-\begin{code}
-
-data OrdList a = SeqList (OrdList a) (OrdList a)
- | ParList (OrdList a) (OrdList a)
- | OrdObj a
- | NoObj
- deriving ()
-
-mkSeqList a b = SeqList a b
-mkParList a b = ParList a b
-mkEmptyList = NoObj
-mkUnitList = OrdObj
-
-\end{code}
-
-%------------------------------------------------------------------------
-
-This simplifies an ordering list, using correctness preserving transformations.
-Notice the duality between @Seq@ and @Par@.
-
-\begin{code}
-{- UNUSED:
-simplOrdList :: OrdList a -> OrdList a
-simplOrdList (SeqList vs) =
- case (concat [
- (case simplOrdList v of
- SeqList xs -> xs
- OrdObj a -> [OrdObj a]
- NoObj -> []
- xs -> [xs]) | v <- vs]) of
- [] -> NoObj
- [x] -> x
- v -> SeqList v
-simplOrdList (ParList vs) =
- case (concat [
- (case simplOrdList v of
- ParList xs -> xs
- OrdObj a -> [OrdObj a]
- NoObj -> []
- xs -> [xs]) | v <- vs]) of
- [] -> NoObj
- [x] -> x
- v -> ParList v
-simplOrdList v = v
--}
-\end{code}
-
-%------------------------------------------------------------------------
-
-First the foldr !
-
-\begin{code}
-{- UNUSED:
-
-foldOrdList
- :: ([b] -> b)
- -> ([b] -> b)
- -> (a -> b)
- -> b
- -> (b -> b -> b)
- -> OrdList a
- -> b
-foldOrdList s p o n c (SeqList vs) = s (map (foldOrdList s p o n c) vs)
-foldOrdList s p o n c (ParList vs) = p (map (foldOrdList s p o n c) vs)
-foldOrdList s p o n c (OrdObj a) = o a
-foldOrdList s p o n c NoObj = n
-
-fnOrdList :: (a -> OrdList b) -> OrdList a -> OrdList b
-fnOrdList f (SeqList vs) = SeqList (map (fnOrdList f) vs)
-fnOrdList f (ParList vs) = ParList (map (fnOrdList f) vs)
-fnOrdList f (OrdObj a) = f a
-fnOrdList f NoObj = NoObj
--}
-\end{code}
-
-This does a concat on an ordering list of ordering lists.
-
-\begin{code}
-{- UNUSED:
-concatOrdList :: OrdList (OrdList a) -> OrdList a
-concatOrdList = fnOrdList id
--}
-\end{code}
-
-This performs a map over an ordering list.
-
-\begin{code}
-{- UNUSED:
-mapOrdList :: (a -> b) -> OrdList a -> OrdList b
-mapOrdList f = fnOrdList (OrdObj.f)
--}
-\end{code}
-
-Here is the reverse over the OrdList.
-
-\begin{code}
-{- UNUSED:
-reverseOrdList :: OrdList a -> OrdList a
-reverseOrdList NoObj = NoObj
-reverseOrdList (OrdObj a) = OrdObj a
-reverseOrdList (ParList vs) = ParList (reverse (map reverseOrdList vs))
-reverseOrdList (SeqList vs) = SeqList (reverse (map reverseOrdList vs))
--}
-\end{code}
-
-Notice this this throws away all potential expression of parrallism.
-
-\begin{code}
-flattenOrdList :: OrdList a -> [a]
-
-flattenOrdList ol
- = -- trace (shows ol "\n") (
- flat ol []
- -- )
- where
- flat :: OrdList a -> [a] -> [a]
- flat NoObj rest = rest
- flat (OrdObj x) rest = x:rest
- flat (ParList a b) rest = flat a (flat b rest)
- flat (SeqList a b) rest = flat a (flat b rest)
-
-{- DEBUGGING ONLY:
-instance Text (OrdList a) where
- showsPrec _ NoObj = showString "_N_"
- showsPrec _ (OrdObj _) = showString "_O_"
- showsPrec _ (ParList a b) = showString "(PAR " . shows a . showChar ')'
- showsPrec _ (SeqList a b) = showString "(SEQ " . shows a . showChar ')'
--}
-\end{code}
-
-This is like mapAccumR, but over OrdList's.
-
-\begin{code}
-{- UNUSED:
-mapAccumROrdList :: (s -> a -> (s,b)) -> s -> OrdList a -> (s,OrdList b)
-mapAccumROrdList f s NoObj = (s,NoObj)
-mapAccumROrdList f s (OrdObj a) =
- case f s a of
- (s',b) -> (s',OrdObj b)
-mapAccumROrdList f s (SeqList vs) =
- case mapAccumR (mapAccumROrdList f) s vs of
- (s',b) -> (s',SeqList b)
-mapAccumROrdList f s (ParList vs) =
- case mapAccumR (mapAccumROrdList f) s vs of
- (s',b) -> (s',ParList b)
-
-mapAccumLOrdList :: (s -> a -> (s,b)) -> s -> OrdList a -> (s,OrdList b)
-mapAccumLOrdList f s NoObj = (s,NoObj)
-mapAccumLOrdList f s (OrdObj a) =
- case f s a of
- (s',b) -> (s',OrdObj b)
-mapAccumLOrdList f s (SeqList vs) =
- case mapAccumL (mapAccumLOrdList f) s vs of
- (s',b) -> (s',SeqList b)
-mapAccumLOrdList f s (ParList vs) =
- case mapAccumL (mapAccumLOrdList f) s vs of
- (s',b) -> (s',ParList b)
-
-mapAccumBOrdList :: (accl -> accr -> x -> (accl, accr, y))
- -> accl -> accr -> OrdList x -> (accl, accr, OrdList y)
-
-mapAccumBOrdList f a b NoObj = (a,b,NoObj)
-mapAccumBOrdList f a b (OrdObj x) =
- case f a b x of
- (a',b',y) -> (a',b',OrdObj y)
-mapAccumBOrdList f a b (SeqList xs) =
- case mapAccumB (mapAccumBOrdList f) a b xs of
- (a',b',ys) -> (a',b',SeqList ys)
-mapAccumBOrdList f a b (ParList xs) =
- case mapAccumB (mapAccumBOrdList f) a b xs of
- (a',b',ys) -> (a',b',ParList ys)
--}
-\end{code}
-
-%------------------------------------------------------------------------
-
-In our printing schema, we use @||@ for parallel operations,
-and @;@ for sequential ones.
-
-\begin{code}
-
-#ifdef _GOFER_
-
-instance (Text a) => Text (OrdList a) where
- showsPrec _ (ParList [a]) = shows a
- showsPrec _ (ParList as ) = showString "( " .
- showOurList as " || " .
- showString " )"
- showsPrec _ (SeqList [a]) = shows a
- showsPrec _ (SeqList as ) = showString "( " .
- showOurList as " ; " .
- showString " )"
- showsPrec _ (OrdObj a) = shows a
- showsPrec _ (NoObj) = showString "$"
-
-showOurList :: (Text a) => [a] -> String -> ShowS
-showOurList [] s = showString ""
-showOurList [a] s = shows a
-showOurList (a:as) s = shows a .
- showString s .
- showOurList as s
-
-#endif
-
-\end{code}
-
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[PragmaInfo]{@PragmaInfos@: The user's pragma requests}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PragmaInfo where
+
+import Ubiq
+\end{code}
+
+\begin{code}
+data PragmaInfo
+ = NoPragmaInfo
+ | IWantToBeINLINEd
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ProtoName where
-import Maybes(Labda)
-import Name(Name)
-import Outputable(NamedThing, Outputable)
-import PreludePS(_PackedString)
-data Labda a
-data Name
-data ProtoName = Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name
-cmpByLocalName :: ProtoName -> ProtoName -> Int#
-cmpProtoName :: ProtoName -> ProtoName -> Int#
-elemByLocalNames :: ProtoName -> [ProtoName] -> Bool
-elemProtoNames :: ProtoName -> [ProtoName] -> Bool
-eqByLocalName :: ProtoName -> ProtoName -> Bool
-eqProtoName :: ProtoName -> ProtoName -> Bool
-isConopPN :: ProtoName -> Bool
-mkPreludeProtoName :: Name -> ProtoName
-instance NamedThing ProtoName
-instance Outputable ProtoName
-
-%************************************************************************
-%* *
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
\section[ProtoName]{@ProtoName@: name type used early in the compiler}
-%* *
-%************************************************************************
\begin{code}
#include "HsVersions.h"
cmpProtoName, eqProtoName, elemProtoNames,
cmpByLocalName, eqByLocalName, elemByLocalNames,
-
- isConopPN,
+
+ isConopPN
-- and to make the module self-sufficient...
- Name, Maybe
-#ifndef __GLASGOW_HASKELL__
- ,TAG_
-#endif
) where
-IMPORT_Trace -- ToDo: rm (debugging)
+import Ubiq{-uitous-}
-import Name ( cmpName, Name
- IF_ATTACK_PRAGMAS(COMMA eqName)
- )
-import Outputable
+import Name ( Name )
+import Outputable ( ifPprShowAll, isConop )
import Pretty
import Util
\end{code}
data ProtoName
= Unk FAST_STRING -- local name in module
- | Imp FAST_STRING -- name of defining module
+ | Qunk FAST_STRING -- qualified name
+ FAST_STRING
+
+ | Imp FAST_STRING -- name of defining module
FAST_STRING -- name used in defining name
[FAST_STRING] -- name of the module whose interfaces
-- told me about this thing
- FAST_STRING -- occurrence name; Nothing => same as field 2
+ FAST_STRING -- occurrence name;
| Prel Name
-{- LATER:
- | Unk2 FAST_INT -- same as Unk but this FAST_INT is
- -- the index into hash table (makes for
- -- superbly great equality comparisons!)
- FAST_STRING
--}
\end{code}
%************************************************************************
(Later the same night...: but, oh yes, you do:
Given two instance decls
-
+
\begin{verbatim}
instance Eq {-PreludeCore-} Foo
instance Bar {-user-defined-} Foo
\end{verbatim}
-you will get a comparison of "Eq" (a Prel) with "Bar" (an {Unk,Imp}))
+you will get a comparison of "Eq" (a Prel) with "Bar" (an {Unk,Imp}))
@cmp_name@ compares either by ``local name'' (the string by which
-the entity is known in this module, renaming and all) or by original
+the entity is known in this module) or by original
name, in which case the module name is also taken into account.
(Just watch what happens on @Imps@...)
= let (_, n2) = getOrigName nm in
_CMP_STRING_ n1 n2
-cmp_name by_local (Prel n1) (Prel n2) = cmpName n1 n2
+cmp_name by_local (Prel n1) (Prel n2) = cmp n1 n2
-- in ordering these things, it's *most* important to have "names" (vs "modules")
-- as the primary comparison key; otherwise, a list of ProtoNames like...
GT__ -> elemByLocalNames x ys
isConopPN :: ProtoName -> Bool
-isConopPN (Unk s) = isConop s
-isConopPN (Imp _ n _ _) = isConop n -- ToDo: should use occurrence name???
+isConopPN (Unk s) = isConop s
+isConopPN (Qunk _ s) = isConop s
+isConopPN (Imp _ n _ _) = isConop n -- ToDo: should use occurrence name???
\end{code}
%************************************************************************
%* *
%************************************************************************
-********** REMOVE THESE WHEN WE FIX THE SET-ery IN RenameBinds4 *********
-
\begin{code}
{- THESE INSTANCES ARE TOO DELICATE TO BE USED!
Use eqByLocalName, ...., etc. instead
instance NamedThing ProtoName where
getOrigName (Unk _) = panic "NamedThing.ProtoName.getOrigName (Unk)"
+ getOrigName (Qunk _ _) = panic "NamedThing.ProtoName.getOrigName (Qunk)"
getOrigName (Imp m s _ _) = (m, s)
getOrigName (Prel name) = getOrigName name
getOccurrenceName (Unk s) = s
+ getOccurrenceName (Qunk _ s) = s
getOccurrenceName (Imp m s _ o) = o
getOccurrenceName (Prel name) = getOccurrenceName name
- hasType pn = False
-
#ifdef DEBUG
getSrcLoc pn = panic "NamedThing.ProtoName.getSrcLoc"
getInformingModules pn = panic "NamedThing.ProtoName.getInformingModule"
- getTheUnique pn = panic "NamedThing.ProtoName.getUnique"
+ getItsUnique pn = panic "NamedThing.ProtoName.getItsUnique"
fromPreludeCore pn = panic "NamedThing.ProtoName.fromPreludeCore"
getExportFlag pn = panic "NamedThing.ProtoName.getExportFlag"
isLocallyDefined pn = panic "NamedThing.ProtoName.isLocallyDefined"
- getType pn = panic "NamedThing.ProtoName.getType"
#endif
\end{code}
\begin{code}
instance Outputable ProtoName where
ppr sty (Unk s) = ppPStr s
+ ppr sty (Qunk m s) = ppBesides [ppPStr m, ppChar '.', ppPStr s]
ppr sty (Prel name) = ppBeside (ppr sty name) (ifPprShowAll sty (ppPStr SLIT("/PREL")))
ppr sty (Imp mod dec imod loc)
= ppBesides [ppPStr mod, ppChar '.', ppPStr dec, pp_occur_name dec loc ]
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SplitUniq where
-import Unique(Unique)
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply
-data Unique
-getSUnique :: SplitUniqSupply -> Unique
-getSUniqueAndDepleted :: SplitUniqSupply -> (Unique, SplitUniqSupply)
-getSUniques :: Int -> SplitUniqSupply -> [Unique]
-getSUniquesAndDepleted :: Int -> SplitUniqSupply -> ([Unique], SplitUniqSupply)
-initSUs :: SplitUniqSupply -> (SplitUniqSupply -> a) -> (SplitUniqSupply, a)
-mapAndUnzipSUs :: (a -> SplitUniqSupply -> (b, c)) -> [a] -> SplitUniqSupply -> ([b], [c])
-mapSUs :: (a -> SplitUniqSupply -> b) -> [a] -> SplitUniqSupply -> [b]
-mkSplitUniqSupply :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld)
-returnSUs :: a -> SplitUniqSupply -> a
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
-thenSUs :: (SplitUniqSupply -> a) -> (a -> SplitUniqSupply -> b) -> SplitUniqSupply -> b
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[Unique]{The @SplitUniqSupply@ data type (``splittable Unique supply'')}
-
-\begin{code}
-#include "HsVersions.h"
-
-module SplitUniq (
- SplitUniqSupply, -- abstract types
-
- getSUnique, getSUniques, -- basic ops
- getSUniqueAndDepleted, getSUniquesAndDepleted, -- DEPRECATED!
-
- SUniqSM(..), -- type: unique supply monad
- initSUs, thenSUs, returnSUs,
- mapSUs, mapAndUnzipSUs,
-
- mkSplitUniqSupply,
- splitUniqSupply,
-
- -- to make interface self-sufficient
- Unique
- IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
-
-#ifndef __GLASGOW_HASKELL__
- ,TAG_
-#endif
- ) where
-
-import Outputable -- class for printing, forcing
-import Pretty -- pretty-printing utilities
-import PrimOps -- ** DIRECTLY **
-import Unique
-import Util
-
-#if defined(__HBC__)
-{-hide import from mkdependHS-}
-import
- Word
-import
- NameSupply renaming ( Name to HBC_Name )
-#endif
-#ifdef __GLASGOW_HASKELL__
-# if __GLASGOW_HASKELL__ >= 26
-import PreludeGlaST
-# else
-import PreludePrimIO
-import PreludeGlaST ( unsafeInterleaveST
- IF_ATTACK_PRAGMAS(COMMA fixST)
- )
-# endif
-#endif
-
-infixr 9 `thenUs`
-
-#ifdef __GLASGOW_HASKELL__
-w2i x = word2Int# x
-i2w x = int2Word# x
-i2w_s x = (x :: Int#)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SplitUniqSupply-type]{@SplitUniqSupply@ type and operations}
-%* *
-%************************************************************************
-
-A value of type @SplitUniqSupply@ is unique, and it can
-supply {\em one} distinct @Unique@. Also, from the supply, one can
-also manufacture an arbitrary number of further @UniqueSupplies@,
-which will be distinct from the first and from all others.
-
-Common type signatures
-\begin{code}
--- mkSplitUniqSupply :: differs by implementation!
-
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
-getSUnique :: SplitUniqSupply -> Unique
-getSUniques :: Int -> SplitUniqSupply -> [Unique]
-getSUniqueAndDepleted :: SplitUniqSupply -> (Unique, SplitUniqSupply)
-getSUniquesAndDepleted :: Int -> SplitUniqSupply -> ([Unique], SplitUniqSupply)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Chalmers implementation of @SplitUniqSupply@}
-%* *
-%************************************************************************
-
-\begin{code}
-#if defined(__HBC__)
-
-data SplitUniqSupply = MkSplit NameSupply
-
-mkSplitUniqSupply :: Char -> SplitUniqSupply -- NB: not the same type
-
-mkSplitUniqSupply _ = MkSplit initialNameSupply
-
-splitUniqSupply (MkSplit us)
- = case (splitNameSupply us) of { (s1, s2) ->
- (MkSplit s1, MkSplit s2) }
-
-getSUnique supply = error "getSUnique" -- mkUniqueGrimily (getName supply)
-
-getSUniques i supply
- = error "getSUniques" -- [ mkUniqueGrimily (getName s) | s <- take i (listNameSupply supply) ]
-
-getSUniqueAndDepleted supply
- = error "getSUniqueAndDepleted"
-{-
- let
- u = mkUniqueGrimily (getName supply)
- (s1, _) = splitNameSupply supply
- in
- (u, s1)
--}
-
-getSUniquesAndDepleted i supply
- = error "getSUniquesAndDepleted"
-{-
- = let
- supplies = take (i+1) (listNameSupply supply)
- uniqs = [ mkUniqueGrimily (getName s) | s <- take i supplies ]
- last_supply = drop i supplies
- in
- (uniqs, last_supply)
--}
-
-#endif {- end of Chalmers implementation -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Glasgow implementation of @SplitUniqSupply@}
-%* *
-%************************************************************************
-
-Glasgow Haskell implementation:
-\begin{code}
-#ifdef __GLASGOW_HASKELL__
-
-# ifdef IGNORE_REFERENTIAL_TRANSPARENCY
-
-data SplitUniqSupply = MkSplitUniqSupply {-does nothing-}
-
-mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
-mkSplitUniqSupply (MkChar c#) = returnPrimIO MkSplitUniqSupply
-
-splitUniqSupply _ = (MkSplitUniqSupply, MkSplitUniqSupply)
-
-getSUnique s = unsafe_mk_unique s
-
-getSUniques i@(MkInt i#) supply = get_from i# supply
- where
- get_from 0# s = []
- get_from n# s
- = unsafe_mk_unique s : get_from (n# `minusInt#` 1#) s
-
-getSUniqueAndDepleted s = (unsafe_mk_unique s, MkSplitUniqSupply)
-
-getSUniquesAndDepleted i@(MkInt i#) s = get_from [] i# s
- where
- get_from acc 0# s = (acc, MkSplitUniqSupply)
- get_from acc n# s
- = get_from (unsafe_mk_unique s : acc) (n# `minusInt#` 1#) s
-
-unsafe_mk_unique supply -- this is the TOTALLY unacceptable bit
- = unsafePerformPrimIO (
- _ccall_ genSymZh junk `thenPrimIO` \ (W# u#) ->
- returnPrimIO (mkUniqueGrimily (w2i (mask# `or#` u#)))
- )
- where
- mask# = (i2w (ord# 'x'#)) `shiftL#` (i2w_s 24#)
- junk = case supply of { MkSplitUniqSupply -> (1::Int) }
-
-# else {- slight attention to referential transparency -}
-
-data SplitUniqSupply
- = MkSplitUniqSupply Int -- make the Unique with this
- SplitUniqSupply SplitUniqSupply
- -- when split => these two supplies
-\end{code}
-
-@mkSplitUniqSupply@ is used to get a @SplitUniqSupply@ started.
-\begin{code}
-
-mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply
-
--- ToDo: 64-bit bugs here!!???
-
-mkSplitUniqSupply (MkChar c#)
- = let
- mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
-
- -- here comes THE MAGIC:
-
- mk_supply#
-{- OLD:
- = unsafe_interleave mk_unique `thenPrimIO` \ uniq ->
- unsafe_interleave mk_supply# `thenPrimIO` \ s1 ->
- unsafe_interleave mk_supply# `thenPrimIO` \ s2 ->
- returnPrimIO (MkSplitUniqSupply uniq s1 s2)
--}
- = unsafe_interleave (
- mk_unique `thenPrimIO` \ uniq ->
- mk_supply# `thenPrimIO` \ s1 ->
- mk_supply# `thenPrimIO` \ s2 ->
- returnPrimIO (MkSplitUniqSupply uniq s1 s2)
- )
- where
- -- inlined copy of unsafeInterleavePrimIO;
- -- this is the single-most-hammered bit of code
- -- in the compiler....
- unsafe_interleave m s
- = let
- (r, new_s) = m s
- in
- (r, s)
-
- mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) ->
- returnPrimIO (MkInt (w2i (mask# `or#` u#)))
- in
- mk_supply#
-
-splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
-\end{code}
-
-\begin{code}
-getSUnique (MkSplitUniqSupply (MkInt n) _ _) = mkUniqueGrimily n
-
-getSUniques i@(MkInt i#) supply = i# `get_from` supply
- where
- get_from 0# _ = []
- get_from n# (MkSplitUniqSupply (MkInt u#) _ s2)
- = mkUniqueGrimily u# : get_from (n# `minusInt#` 1#) s2
-
-getSUniqueAndDepleted (MkSplitUniqSupply (MkInt n) s1 _) = (mkUniqueGrimily n, s1)
-
-getSUniquesAndDepleted i@(MkInt i#) supply = get_from [] i# supply
- where
- get_from acc 0# s = (acc, s)
- get_from acc n# (MkSplitUniqSupply (MkInt u#) _ s2)
- = get_from (mkUniqueGrimily u# : acc) (n# `minusInt#` 1#) s2
-
-# endif {- slight attention to referential transparency -}
-
-#endif {- end of Glasgow implementation -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SplitUniq-monad]{Splittable Unique-supply monad}
-%* *
-%************************************************************************
-
-\begin{code}
-type SUniqSM result = SplitUniqSupply -> result
-
--- the initUs function also returns the final SplitUniqSupply
-
-initSUs :: SplitUniqSupply -> SUniqSM a -> (SplitUniqSupply, a)
-
-initSUs init_us m
- = case (splitUniqSupply init_us) of { (s1, s2) ->
- (s2, m s1) }
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenSUs #-}
-{-# INLINE returnSUs #-}
-{-# INLINE splitUniqSupply #-}
-#endif
-\end{code}
-
-@thenSUs@ is where we split the @SplitUniqSupply@.
-\begin{code}
-thenSUs :: SUniqSM a -> (a -> SUniqSM b) -> SUniqSM b
-
-thenSUs expr cont us
- = case (splitUniqSupply us) of { (s1, s2) ->
- case (expr s1) of { result ->
- cont result s2 }}
-\end{code}
-
-\begin{code}
-returnSUs :: a -> SUniqSM a
-returnSUs result us = result
-
-mapSUs :: (a -> SUniqSM b) -> [a] -> SUniqSM [b]
-
-mapSUs f [] = returnSUs []
-mapSUs f (x:xs)
- = f x `thenSUs` \ r ->
- mapSUs f xs `thenSUs` \ rs ->
- returnSUs (r:rs)
-
-mapAndUnzipSUs :: (a -> SUniqSM (b,c)) -> [a] -> SUniqSM ([b],[c])
-
-mapAndUnzipSUs f [] = returnSUs ([],[])
-mapAndUnzipSUs f (x:xs)
- = f x `thenSUs` \ (r1, r2) ->
- mapAndUnzipSUs f xs `thenSUs` \ (rs1, rs2) ->
- returnSUs (r1:rs1, r2:rs2)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SrcLoc where
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-data SrcLoc
-mkBuiltinSrcLoc :: SrcLoc
-mkGeneratedSrcLoc :: SrcLoc
-mkSrcLoc :: _PackedString -> _PackedString -> SrcLoc
-mkSrcLoc2 :: _PackedString -> Int -> SrcLoc
-mkUnknownSrcLoc :: SrcLoc
-unpackSrcLoc :: SrcLoc -> (_PackedString, _PackedString)
-instance Outputable SrcLoc
-
unpackSrcLoc
) where
-import Outputable
+import Ubiq
+
+import PprStyle ( PprStyle(..) )
import Pretty
-import Util
\end{code}
%************************************************************************
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[UniqSupply]{The @UniqueSupply@ data type and a (monadic) supply thereof}
+
+\begin{code}
+#include "HsVersions.h"
+
+module UniqSupply (
+
+ UniqSupply, -- Abstractly
+
+ getUnique, getUniques, -- basic ops
+
+ UniqSM(..), -- type: unique supply monad
+ initUs, thenUs, returnUs,
+ mapUs, mapAndUnzipUs,
+
+ mkSplitUniqSupply,
+ splitUniqSupply,
+
+ -- and the access functions for the `builtin' UniqueSupply
+ getBuiltinUniques, mkBuiltinUnique,
+ mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
+ ) where
+
+import Ubiq{-uitous-}
+
+import Unique
+import Util
+
+import PreludeGlaST
+
+w2i x = word2Int# x
+i2w x = int2Word# x
+i2w_s x = (x :: Int#)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Splittable Unique supply: @UniqSupply@}
+%* *
+%************************************************************************
+
+%************************************************************************
+%* *
+\subsubsection[UniqSupply-type]{@UniqSupply@ type and operations}
+%* *
+%************************************************************************
+
+A value of type @UniqSupply@ is unique, and it can
+supply {\em one} distinct @Unique@. Also, from the supply, one can
+also manufacture an arbitrary number of further @UniqueSupplies@,
+which will be distinct from the first and from all others.
+
+\begin{code}
+data UniqSupply
+ = MkSplitUniqSupply Int -- make the Unique with this
+ UniqSupply UniqSupply
+ -- when split => these two supplies
+\end{code}
+
+\begin{code}
+mkSplitUniqSupply :: Char -> PrimIO UniqSupply
+
+splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
+getUnique :: UniqSupply -> Unique
+getUniques :: Int -> UniqSupply -> [Unique]
+\end{code}
+
+\begin{code}
+mkSplitUniqSupply (MkChar c#)
+ = let
+ mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
+
+ -- here comes THE MAGIC:
+
+ mk_supply#
+ = unsafe_interleave (
+ mk_unique `thenPrimIO` \ uniq ->
+ mk_supply# `thenPrimIO` \ s1 ->
+ mk_supply# `thenPrimIO` \ s2 ->
+ returnPrimIO (MkSplitUniqSupply uniq s1 s2)
+ )
+ where
+ -- inlined copy of unsafeInterleavePrimIO;
+ -- this is the single-most-hammered bit of code
+ -- in the compiler....
+ unsafe_interleave m s
+ = let
+ (r, new_s) = m s
+ in
+ (r, s)
+
+ mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) ->
+ returnPrimIO (MkInt (w2i (mask# `or#` u#)))
+ in
+ mk_supply#
+
+splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
+\end{code}
+
+\begin{code}
+getUnique (MkSplitUniqSupply (MkInt n) _ _) = mkUniqueGrimily n
+
+getUniques i@(MkInt i#) supply = i# `get_from` supply
+ where
+ get_from 0# _ = []
+ get_from n# (MkSplitUniqSupply (MkInt u#) _ s2)
+ = mkUniqueGrimily u# : get_from (n# `minusInt#` 1#) s2
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@}
+%* *
+%************************************************************************
+
+\begin{code}
+type UniqSM result = UniqSupply -> result
+
+-- the initUs function also returns the final UniqSupply
+
+initUs :: UniqSupply -> UniqSM a -> (UniqSupply, a)
+
+initUs init_us m
+ = case (splitUniqSupply init_us) of { (s1, s2) ->
+ (s2, m s1) }
+
+{-# INLINE thenUs #-}
+{-# INLINE returnUs #-}
+{-# INLINE splitUniqSupply #-}
+\end{code}
+
+@thenUs@ is where we split the @UniqSupply@.
+\begin{code}
+thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
+
+thenUs expr cont us
+ = case (splitUniqSupply us) of { (s1, s2) ->
+ case (expr s1) of { result ->
+ cont result s2 }}
+\end{code}
+
+\begin{code}
+returnUs :: a -> UniqSM a
+returnUs result us = result
+
+mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
+
+mapUs f [] = returnUs []
+mapUs f (x:xs)
+ = f x `thenUs` \ r ->
+ mapUs f xs `thenUs` \ rs ->
+ returnUs (r:rs)
+
+mapAndUnzipUs :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c])
+
+mapAndUnzipUs f [] = returnUs ([],[])
+mapAndUnzipUs f (x:xs)
+ = f x `thenUs` \ (r1, r2) ->
+ mapAndUnzipUs f xs `thenUs` \ (rs1, rs2) ->
+ returnUs (r1:rs1, r2:rs2)
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[UniqueSupplies-compiler]{@UniqueSupplies@ specific to the compiler}
+%* *
+%************************************************************************
+
+\begin{code}
+mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+ mkBuiltinUnique :: Int -> Unique
+
+mkBuiltinUnique i = mkUnique 'B' i
+mkPseudoUnique1 i = mkUnique 'C' i -- used for getItsUnique on Regs
+mkPseudoUnique2 i = mkUnique 'D' i -- ditto
+mkPseudoUnique3 i = mkUnique 'E' i -- ditto
+
+getBuiltinUniques :: Int -> [Unique]
+getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
+\end{code}
+
+The following runs a uniq monad expression, using builtin uniq values:
+\begin{code}
+--runBuiltinUs :: UniqSM a -> a
+--runBuiltinUs m = snd (initUs uniqSupply_B m)
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Unique where
-import CharSeq(CSeq)
-import PreludePS(_PackedString)
-import Pretty(PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-infixr 9 `thenUs`
-data CSeq
-data PrimOp
-data SplitUniqSupply
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique
-data UniqueSupply
-absentErrorIdKey :: Unique
-addrDataConKey :: Unique
-addrPrimTyConKey :: Unique
-addrTyConKey :: Unique
-appendIdKey :: Unique
-arrayPrimTyConKey :: Unique
-augmentIdKey :: Unique
-binaryClassKey :: Unique
-boolTyConKey :: Unique
-buildDataConKey :: Unique
-buildIdKey :: Unique
-byteArrayPrimTyConKey :: Unique
-cCallableClassKey :: Unique
-cReturnableClassKey :: Unique
-charDataConKey :: Unique
-charPrimTyConKey :: Unique
-charTyConKey :: Unique
-cmpTagTyConKey :: Unique
-cmpUnique :: Unique -> Unique -> Int#
-consDataConKey :: Unique
-dialogueTyConKey :: Unique
-doubleDataConKey :: Unique
-doublePrimTyConKey :: Unique
-doubleTyConKey :: Unique
-enumClassKey :: Unique
-eqClassKey :: Unique
-eqTagDataConKey :: Unique
-eqUnique :: Unique -> Unique -> Bool
-errorIdKey :: Unique
-falseDataConKey :: Unique
-floatDataConKey :: Unique
-floatPrimTyConKey :: Unique
-floatTyConKey :: Unique
-floatingClassKey :: Unique
-foldlIdKey :: Unique
-foldrIdKey :: Unique
-forkIdKey :: Unique
-fractionalClassKey :: Unique
-getBuiltinUniques :: Int -> [Unique]
-getUnique :: UniqueSupply -> (UniqueSupply, Unique)
-getUniques :: Int -> UniqueSupply -> (UniqueSupply, [Unique])
-gtTagDataConKey :: Unique
-iOTyConKey :: Unique
-initUs :: UniqueSupply -> (UniqueSupply -> (UniqueSupply, a)) -> (UniqueSupply, a)
-intDataConKey :: Unique
-intPrimTyConKey :: Unique
-intTyConKey :: Unique
-integerDataConKey :: Unique
-integerMinusOneIdKey :: Unique
-integerPlusOneIdKey :: Unique
-integerPlusTwoIdKey :: Unique
-integerTyConKey :: Unique
-integerZeroIdKey :: Unique
-integralClassKey :: Unique
-ixClassKey :: Unique
-liftDataConKey :: Unique
-liftTyConKey :: Unique
-listTyConKey :: Unique
-ltTagDataConKey :: Unique
-mallocPtrDataConKey :: Unique
-mallocPtrPrimTyConKey :: Unique
-mallocPtrTyConKey :: Unique
-mapAndUnzipUs :: (a -> UniqueSupply -> (UniqueSupply, (b, c))) -> [a] -> UniqueSupply -> (UniqueSupply, ([b], [c]))
-mapUs :: (a -> UniqueSupply -> (UniqueSupply, b)) -> [a] -> UniqueSupply -> (UniqueSupply, [b])
-mkBuiltinUnique :: Int -> Unique
-mkPrimOpIdUnique :: PrimOp -> Unique
-mkPseudoUnique1 :: Int -> Unique
-mkPseudoUnique2 :: Int -> Unique
-mkPseudoUnique3 :: Int -> Unique
-mkTupleDataConUnique :: Int -> Unique
-mkUnifiableTyVarUnique :: Int -> Unique
-mkUniqueGrimily :: Int# -> Unique
-mkUniqueSupplyGrimily :: SplitUniqSupply -> UniqueSupply
-mutableArrayPrimTyConKey :: Unique
-mutableByteArrayPrimTyConKey :: Unique
-nilDataConKey :: Unique
-numClassKey :: Unique
-ordClassKey :: Unique
-packCStringIdKey :: Unique
-parErrorIdKey :: Unique
-parIdKey :: Unique
-patErrorIdKey :: Unique
-pprUnique :: Unique -> Int -> Bool -> PrettyRep
-pprUnique10 :: Unique -> Int -> Bool -> PrettyRep
-primIoTyConKey :: Unique
-ratioDataConKey :: Unique
-ratioTyConKey :: Unique
-rationalTyConKey :: Unique
-realClassKey :: Unique
-realFloatClassKey :: Unique
-realFracClassKey :: Unique
-realWorldPrimIdKey :: Unique
-realWorldTyConKey :: Unique
-return2GMPsDataConKey :: Unique
-return2GMPsTyConKey :: Unique
-returnIntAndGMPDataConKey :: Unique
-returnIntAndGMPTyConKey :: Unique
-returnUs :: a -> UniqueSupply -> (UniqueSupply, a)
-runBuiltinUs :: (UniqueSupply -> (UniqueSupply, a)) -> a
-runSTIdKey :: Unique
-seqIdKey :: Unique
-showUnique :: Unique -> _PackedString
-stTyConKey :: Unique
-stablePtrDataConKey :: Unique
-stablePtrPrimTyConKey :: Unique
-stablePtrTyConKey :: Unique
-stateAndAddrPrimDataConKey :: Unique
-stateAndAddrPrimTyConKey :: Unique
-stateAndArrayPrimDataConKey :: Unique
-stateAndArrayPrimTyConKey :: Unique
-stateAndByteArrayPrimDataConKey :: Unique
-stateAndByteArrayPrimTyConKey :: Unique
-stateAndCharPrimDataConKey :: Unique
-stateAndCharPrimTyConKey :: Unique
-stateAndDoublePrimDataConKey :: Unique
-stateAndDoublePrimTyConKey :: Unique
-stateAndFloatPrimDataConKey :: Unique
-stateAndFloatPrimTyConKey :: Unique
-stateAndIntPrimDataConKey :: Unique
-stateAndIntPrimTyConKey :: Unique
-stateAndMallocPtrPrimDataConKey :: Unique
-stateAndMallocPtrPrimTyConKey :: Unique
-stateAndMutableArrayPrimDataConKey :: Unique
-stateAndMutableArrayPrimTyConKey :: Unique
-stateAndMutableByteArrayPrimDataConKey :: Unique
-stateAndMutableByteArrayPrimTyConKey :: Unique
-stateAndPtrPrimDataConKey :: Unique
-stateAndPtrPrimTyConKey :: Unique
-stateAndStablePtrPrimDataConKey :: Unique
-stateAndStablePtrPrimTyConKey :: Unique
-stateAndSynchVarPrimDataConKey :: Unique
-stateAndSynchVarPrimTyConKey :: Unique
-stateAndWordPrimDataConKey :: Unique
-stateAndWordPrimTyConKey :: Unique
-stateDataConKey :: Unique
-statePrimTyConKey :: Unique
-stateTyConKey :: Unique
-stringTyConKey :: Unique
-synchVarPrimTyConKey :: Unique
-textClassKey :: Unique
-thenUs :: (UniqueSupply -> (UniqueSupply, a)) -> (a -> UniqueSupply -> (UniqueSupply, b)) -> UniqueSupply -> (UniqueSupply, b)
-traceIdKey :: Unique
-trueDataConKey :: Unique
-u2i :: Unique -> Int#
-uniqSupply_u :: UniqueSupply
-unpackCString2IdKey :: Unique
-unpackCStringAppendIdKey :: Unique
-unpackCStringFoldrIdKey :: Unique
-unpackCStringIdKey :: Unique
-unpkUnifiableTyVarUnique :: Unique -> Int
-voidPrimIdKey :: Unique
-voidPrimTyConKey :: Unique
-wordDataConKey :: Unique
-wordPrimTyConKey :: Unique
-wordTyConKey :: Unique
-instance Eq Unique
-instance Ord Unique
-instance Text Unique
-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[Unique]{The @Unique@ data type and a (monadic) supply thereof}
+\section[Unique]{The @Unique@ data type}
@Uniques@ are used to distinguish entities in the compiler (@Ids@,
@Classes@, etc.) from each other. Thus, @Uniques@ are the basic
\begin{code}
#include "HsVersions.h"
+--<mkdependHS:friends> UniqSupply
+
module Unique (
Unique,
- UniqueSupply, -- abstract types
u2i, -- hack: used in UniqFM
- getUnique, getUniques, -- basic ops
- eqUnique, cmpUnique, -- comparison is everything!
-
---not exported: mkUnique, unpkUnique,
- mkUniqueGrimily, -- use in SplitUniq only!
- mkUniqueSupplyGrimily, -- ditto! (but FALSE: WDP 95/01)
- mkUnifiableTyVarUnique,
- unpkUnifiableTyVarUnique,
- showUnique, pprUnique, pprUnique10,
-
- UniqSM(..), -- type: unique supply monad
- initUs, thenUs, returnUs,
- mapUs, mapAndUnzipUs,
-
- -- the pre-defined unique supplies:
-{- NOT exported:
- uniqSupply_r, uniqSupply_t, uniqSupply_d,
- uniqSupply_s, uniqSupply_c, uniqSupply_T,
- uniqSupply_f,
- uniqSupply_P,
--}
- uniqSupply_u,
-#ifdef DPH
- -- otherwise, not exported
- uniqSupply_p, uniqSupply_S, uniqSupply_L,
-#endif
- -- and the access functions for the `builtin' UniqueSupply
- getBuiltinUniques, mkBuiltinUnique, runBuiltinUs,
- mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+ pprUnique, pprUnique10, showUnique,
+
+ mkUnique, -- Used in UniqSupply
+ mkUniqueGrimily, -- Used in UniqSupply only!
-- now all the built-in Uniques (and functions to make them)
-- [the Oh-So-Wonderful Haskell module system wins again...]
+ mkAlphaTyVarUnique,
mkPrimOpIdUnique,
mkTupleDataConUnique,
+ mkTupleTyConUnique,
- absentErrorIdKey,
- runSTIdKey, realWorldPrimIdKey,
+ absentErrorIdKey, -- alphabetical...
+ addrDataConKey,
+ addrPrimTyConKey,
+ addrTyConKey,
+ appendIdKey,
arrayPrimTyConKey,
- byteArrayPrimTyConKey, --UNUSED: byteArrayDataConKey, byteArrayTyConKey,
+ augmentIdKey,
binaryClassKey,
- boolTyConKey, buildDataConKey, buildIdKey, charDataConKey,
- charPrimTyConKey, charTyConKey, cmpTagTyConKey,
+ boolTyConKey,
+ buildDataConKey,
+ buildIdKey,
+ byteArrayPrimTyConKey,
+ cCallableClassKey,
+ cReturnableClassKey,
+ charDataConKey,
+ charPrimTyConKey,
+ charTyConKey,
consDataConKey,
- dialogueTyConKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
- enumClassKey, eqClassKey,
- eqTagDataConKey, errorIdKey,
- falseDataConKey, floatDataConKey,
- floatPrimTyConKey, floatTyConKey, floatingClassKey,
- foldlIdKey, foldrIdKey,
+ enumClassKey,
+ enumFromClassOpKey,
+ enumFromThenClassOpKey,
+ enumFromThenToClassOpKey,
+ enumFromToClassOpKey,
+ eqClassKey,
+ eqClassOpKey,
+ eqDataConKey,
+ errorIdKey,
+ falseDataConKey,
+ floatDataConKey,
+ floatPrimTyConKey,
+ floatTyConKey,
+ floatingClassKey,
+ foldlIdKey,
+ foldrIdKey,
forkIdKey,
fractionalClassKey,
- gtTagDataConKey, --UNUSED: iOErrorTyConKey,
---UNUSED: iOIntPrimTyConKey, -- UNUSED: int2IntegerIdKey,
+ fromIntClassOpKey,
+ fromIntegerClassOpKey,
+ fromRationalClassOpKey,
+ funTyConKey,
+ geClassOpKey,
+ gtDataConKey,
iOTyConKey,
intDataConKey,
- wordPrimTyConKey, wordTyConKey, wordDataConKey,
- addrPrimTyConKey, addrTyConKey, addrDataConKey,
- intPrimTyConKey, intTyConKey,
- integerDataConKey, integerTyConKey, integralClassKey,
+ intPrimTyConKey,
+ intTyConKey,
+ integerDataConKey,
+ integerMinusOneIdKey,
+ integerPlusOneIdKey,
+ integerPlusTwoIdKey,
+ integerTyConKey,
+ integerZeroIdKey,
+ integralClassKey,
ixClassKey,
---UNUSED: lexIdKey,
- liftDataConKey, liftTyConKey, listTyConKey,
- ltTagDataConKey,
- mutableArrayPrimTyConKey, -- UNUSED: mutableArrayDataConKey, mutableArrayTyConKey,
- mutableByteArrayPrimTyConKey, -- UNUSED: mutableByteArrayDataConKey,
---UNUSED: mutableByteArrayTyConKey,
- synchVarPrimTyConKey,
- nilDataConKey, numClassKey, ordClassKey,
- parIdKey, parErrorIdKey,
-#ifdef GRAN
- parGlobalIdKey, parLocalIdKey, copyableIdKey, noFollowIdKey,
-#endif
+ liftDataConKey,
+ liftTyConKey,
+ listTyConKey,
+ ltDataConKey,
+ mainIdKey,
+ mainPrimIOIdKey,
+ mallocPtrDataConKey,
+ mallocPtrPrimTyConKey,
+ mallocPtrTyConKey,
+ monadClassKey,
+ monadZeroClassKey,
+ mutableArrayPrimTyConKey,
+ mutableByteArrayPrimTyConKey,
+ negateClassOpKey,
+ nilDataConKey,
+ numClassKey,
+ ordClassKey,
+ orderingTyConKey,
+ packCStringIdKey,
+ parErrorIdKey,
+ parIdKey,
patErrorIdKey,
- ratioDataConKey, ratioTyConKey,
+ primIoTyConKey,
+ ratioDataConKey,
+ ratioTyConKey,
rationalTyConKey,
---UNUSED: readParenIdKey,
- realClassKey, realFloatClassKey,
+ readClassKey,
+ realClassKey,
+ realFloatClassKey,
realFracClassKey,
---UNUSED: requestTyConKey, responseTyConKey,
- return2GMPsDataConKey, return2GMPsTyConKey,
- returnIntAndGMPDataConKey, returnIntAndGMPTyConKey,
- seqIdKey, -- UNUSED: seqIntPrimTyConKey,
---UNUSED: seqTyConKey,
---UNUSED: showParenIdKey,
---UNUSED: showSpaceIdKey,
- statePrimTyConKey, stateTyConKey, stateDataConKey,
- voidPrimTyConKey,
+ realWorldPrimIdKey,
realWorldTyConKey,
- stablePtrPrimTyConKey, stablePtrTyConKey, stablePtrDataConKey,
- mallocPtrPrimTyConKey, mallocPtrTyConKey, mallocPtrDataConKey,
- stateAndPtrPrimTyConKey,
- stateAndPtrPrimDataConKey,
- stateAndCharPrimTyConKey,
+ return2GMPsDataConKey,
+ return2GMPsTyConKey,
+ returnIntAndGMPDataConKey,
+ returnIntAndGMPTyConKey,
+ runSTIdKey,
+ seqIdKey,
+ showClassKey,
+ stTyConKey,
+ stablePtrDataConKey,
+ stablePtrPrimTyConKey,
+ stablePtrTyConKey,
+ stateAndAddrPrimDataConKey,
+ stateAndAddrPrimTyConKey,
+ stateAndArrayPrimDataConKey,
+ stateAndArrayPrimTyConKey,
+ stateAndByteArrayPrimDataConKey,
+ stateAndByteArrayPrimTyConKey,
stateAndCharPrimDataConKey,
- stateAndIntPrimTyConKey,
+ stateAndCharPrimTyConKey,
+ stateAndDoublePrimDataConKey,
+ stateAndDoublePrimTyConKey,
+ stateAndFloatPrimDataConKey,
+ stateAndFloatPrimTyConKey,
stateAndIntPrimDataConKey,
- stateAndWordPrimTyConKey,
- stateAndWordPrimDataConKey,
- stateAndAddrPrimTyConKey,
- stateAndAddrPrimDataConKey,
- stateAndStablePtrPrimTyConKey,
- stateAndStablePtrPrimDataConKey,
- stateAndMallocPtrPrimTyConKey,
+ stateAndIntPrimTyConKey,
stateAndMallocPtrPrimDataConKey,
- stateAndFloatPrimTyConKey,
- stateAndFloatPrimDataConKey,
- stateAndDoublePrimTyConKey,
- stateAndDoublePrimDataConKey,
- stateAndArrayPrimTyConKey,
- stateAndArrayPrimDataConKey,
- stateAndMutableArrayPrimTyConKey,
+ stateAndMallocPtrPrimTyConKey,
stateAndMutableArrayPrimDataConKey,
- stateAndByteArrayPrimTyConKey,
- stateAndByteArrayPrimDataConKey,
- stateAndMutableByteArrayPrimTyConKey,
+ stateAndMutableArrayPrimTyConKey,
stateAndMutableByteArrayPrimDataConKey,
- stateAndSynchVarPrimTyConKey,
+ stateAndMutableByteArrayPrimTyConKey,
+ stateAndPtrPrimDataConKey,
+ stateAndPtrPrimTyConKey,
+ stateAndStablePtrPrimDataConKey,
+ stateAndStablePtrPrimTyConKey,
stateAndSynchVarPrimDataConKey,
+ stateAndSynchVarPrimTyConKey,
+ stateAndWordPrimDataConKey,
+ stateAndWordPrimTyConKey,
+ stateDataConKey,
+ statePrimTyConKey,
+ stateTyConKey,
stringTyConKey,
- stTyConKey, primIoTyConKey,
---UNUSED: ioResultTyConKey,
- textClassKey,
+ synchVarPrimTyConKey,
traceIdKey,
trueDataConKey,
unpackCString2IdKey,
unpackCStringAppendIdKey,
unpackCStringFoldrIdKey,
unpackCStringIdKey,
- augmentIdKey,
- appendIdKey,
---NO: rangeComplaintIdKey,
- packCStringIdKey,
- integerZeroIdKey, integerPlusOneIdKey,
- integerPlusTwoIdKey, integerMinusOneIdKey,
voidPrimIdKey,
- cCallableClassKey,
- cReturnableClassKey,
---UNUSED: packedStringTyConKey, psDataConKey, cpsDataConKey,
-
- -- to make interface self-sufficient
- PrimOp, SplitUniqSupply, CSeq
-
-#ifndef __GLASGOW_HASKELL__
- , TAG_
+ voidPrimTyConKey,
+ wordDataConKey,
+ wordPrimTyConKey,
+ wordTyConKey
+#ifdef GRAN
+ , copyableIdKey
+ , noFollowIdKey
+ , parGlobalIdKey
+ , parLocalIdKey
#endif
+ -- to make interface self-sufficient
) where
-import Outputable -- class for printing, forcing
-import Pretty
-import PrimOps -- ** DIRECTLY **
-import SplitUniq
-import Util
-
-#ifndef __GLASGOW_HASKELL__
-{-hide import from mkdependHS-}
-import
- Word
-#endif
-#ifdef __GLASGOW_HASKELL__
import PreludeGlaST
-#endif
-infixr 9 `thenUs`
+import Ubiq{-uitous-}
+
+import Pretty
+import Util
\end{code}
%************************************************************************
\begin{code}
u2i :: Unique -> FAST_INT
-#ifdef __GLASGOW_HASKELL__
-
data Unique = MkUnique Int#
u2i (MkUnique i) = i
-
-#else
-
-data Unique = MkUnique Word{-#STRICT#-}
-u2i (MkUnique w) = wordToInt w
-
-#endif
\end{code}
Now come the functions which construct uniques from their pieces, and vice versa.
mkUnifiableTyVarUnique :: Int -> Unique -- Injects a subst-array index into the Unique type
unpkUnifiableTyVarUnique :: Unique -> Int -- The reverse process
-#ifdef __GLASGOW_HASKELL__
-mkUniqueGrimily :: Int# -> Unique -- A trap-door for SplitUniq
-#else
-mkUniqueGrimily :: Int -> Unique
-#endif
+mkUniqueGrimily :: Int# -> Unique -- A trap-door for UniqSupply
\end{code}
\begin{code}
-#ifdef __GLASGOW_HASKELL__
mkUniqueGrimily x = MkUnique x
-#else
-mkUniqueGrimily x = MkUnique (fromInteger (toInteger x))
-#endif
mkUnifiableTyVarUnique i = mkUnique '_'{-MAGIC CHAR-} i
-- pop the Char in the top 8 bits of the Unique(Supply)
-#ifdef __GLASGOW_HASKELL__
-
-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM
w2i x = word2Int# x
i = MkInt (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
in
(tag, i)
-# if __GLASGOW_HASKELL__ >= 23
where
shiftr x y = shiftRA# x y
-# else
- shiftr x y = shiftR# x y
-# endif
-
-#else {-probably HBC-}
-
-mkUnique c i
- = MkUnique (((fromInt (ord c)) `bitLsh` 24) `bitOr` (fromInt i))
-
-unpkUnique (MkUnique u)
- = let
- tag = chr (wordToInt (u `bitRsh` 24))
- i = wordToInt (u `bitAnd` 16777215 {-0x00ffffff-})
- in
- (tag, i)
-
-#endif {-probably HBC-}
\end{code}
%************************************************************************
(equality on @Uniques@ is v common).
\begin{code}
-#ifdef __GLASGOW_HASKELL__
-
-{-# INLINE eqUnique #-} -- this is Hammered City here...
-{-# INLINE cmpUnique #-}
-
eqUnique (MkUnique u1) (MkUnique u2) = u1 ==# u2
ltUnique (MkUnique u1) (MkUnique u2) = u1 <# u2
leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2
cmpUnique (MkUnique u1) (MkUnique u2)
= if u1 ==# u2 then EQ_ else if u1 <# u2 then LT_ else GT_
-#else
-eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2
-ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2
-leUnique (MkUnique u1) (MkUnique u2) = u1 <= u2
-
-cmpUnique (MkUnique u1) (MkUnique u2)
- = if u1 == u2 then EQ_ else if u1 < u2 then LT_ else GT_
-#endif
-
instance Eq Unique where
a == b = eqUnique a b
a /= b = not (eqUnique a b)
a <= b = leUnique a b
a > b = not (leUnique a b)
a >= b = not (ltUnique a b)
-#ifdef __GLASGOW_HASKELL__
_tagCmp a b = case cmpUnique a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-\end{code}
-And for output:
-\begin{code}
-{- OLD:
-instance Outputable Unique where
- ppr any_style uniq
- = case unpkUnique uniq of
- (tag, u) -> ppStr (tag : iToBase62 u)
--}
+instance Ord3 Unique where
+ cmp = cmpUnique
+
\end{code}
We do sometimes make strings with @Uniques@ in them:
showUnique :: Unique -> FAST_STRING
showUnique uniq = _PK_ (ppShow 80 (pprUnique uniq))
+instance Outputable Unique where
+ ppr sty u = pprUnique u
+
instance Text Unique where
showsPrec p uniq rest = _UNPK_ (showUnique uniq)
readsPrec p = panic "no readsPrec for Unique"
+
+instance NamedThing Unique where
+ getItsUnique u = u
\end{code}
%************************************************************************
\begin{code}
iToBase62 :: Int -> Pretty
-#ifdef __GLASGOW_HASKELL__
iToBase62 n@(I# n#)
= ASSERT(n >= 0)
let
bytes = case chars62 of { _ByteArray bounds_who_needs_'em bytes -> bytes }
in
- if n# <# 62# then
+ if n# <# 62# then
case (indexCharArray# bytes n#) of { c ->
ppChar (C# c) }
else
| otherwise
= writeCharArray ch_array i (str !! i) `seqStrictlyST`
fill_in ch_array (i+1) lim str
-
-#else {- not GHC -}
-iToBase62 n
- = ASSERT(n >= 0)
- if n < 62 then
- ppChar (chars62 ! n)
- else
- case (quotRem n 62) of { (q, r) ->
- ppBeside (iToBase62 q) (ppChar (chars62 ! r)) }
-
--- keep this at top level! (bug on 94/10/24 WDP)
-chars62 :: Array Int Char
-chars62
- = array (0,61) (zipWith (:=) [0..] "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
-#endif {- not GHC -}
\end{code}
%************************************************************************
%* *
%************************************************************************
+Allocation of unique supply characters:
+ a-z: lower case chars for unique supplies (see Main.lhs)
+ B: builtin (see UniqSupply.lhs)
+ C-E: pseudo uniques (see UniqSupply.lhs)
+ _: unifiable tyvars (above)
+ 1-8: prelude things below
+
\begin{code}
-mkPreludeClassUnique i = mkUnique '1' i
-mkPreludeTyConUnique i = mkUnique '2' i
-mkPreludeDataConUnique i = mkUnique 'Y' i -- must be alphabetic
-mkTupleDataConUnique i = mkUnique 'Z' i -- ditto (*may* be used in C labels)
--- mkPrimOpIdUnique op: see below (uses '5')
-mkPreludeMiscIdUnique i = mkUnique '7' i
+mkAlphaTyVarUnique i = mkUnique '1' i
+
+mkPreludeClassUnique i = mkUnique '2' i
+mkPreludeTyConUnique i = mkUnique '3' i
+mkTupleTyConUnique a = mkUnique '4' a
+
+mkPreludeDataConUnique i = mkUnique '5' i -- must be alphabetic
+mkTupleDataConUnique a = mkUnique '6' a -- ditto (*may* be used in C labels)
+
+mkPrimOpIdUnique op = mkUnique '7' op
+mkPreludeMiscIdUnique i = mkUnique '8' i
\end{code}
%************************************************************************
realFloatClassKey = mkPreludeClassUnique 9
ixClassKey = mkPreludeClassUnique 10
enumClassKey = mkPreludeClassUnique 11
-textClassKey = mkPreludeClassUnique 12
-binaryClassKey = mkPreludeClassUnique 13
-cCallableClassKey = mkPreludeClassUnique 14
-cReturnableClassKey = mkPreludeClassUnique 15
-#ifdef DPH
-pidClassKey = mkPreludeClassUnique 16
-processorClassKey = mkPreludeClassUnique 17
-#endif {- Data Parallel Haskell -}
+showClassKey = mkPreludeClassUnique 12
+readClassKey = mkPreludeClassUnique 13
+monadClassKey = mkPreludeClassUnique 14
+monadZeroClassKey = mkPreludeClassUnique 15
+binaryClassKey = mkPreludeClassUnique 16
+cCallableClassKey = mkPreludeClassUnique 17
+cReturnableClassKey = mkPreludeClassUnique 18
\end{code}
%************************************************************************
arrayPrimTyConKey = mkPreludeTyConUnique 3
boolTyConKey = mkPreludeTyConUnique 4
byteArrayPrimTyConKey = mkPreludeTyConUnique 5
---UNUSED:byteArrayTyConKey = mkPreludeTyConUnique 6
charPrimTyConKey = mkPreludeTyConUnique 7
charTyConKey = mkPreludeTyConUnique 8
-cmpTagTyConKey = mkPreludeTyConUnique 9
-dialogueTyConKey = mkPreludeTyConUnique 10
-doublePrimTyConKey = mkPreludeTyConUnique 11
-doubleTyConKey = mkPreludeTyConUnique 12
-floatPrimTyConKey = mkPreludeTyConUnique 13
-floatTyConKey = mkPreludeTyConUnique 14
---UNUSED:iOErrorTyConKey = mkPreludeTyConUnique 14
---UNUSED:iOIntPrimTyConKey = mkPreludeTyConUnique 15
-iOTyConKey = mkPreludeTyConUnique 16
-intPrimTyConKey = mkPreludeTyConUnique 17
-intTyConKey = mkPreludeTyConUnique 18
-integerTyConKey = mkPreludeTyConUnique 19
-liftTyConKey = mkPreludeTyConUnique 20
-listTyConKey = mkPreludeTyConUnique 21
-mallocPtrPrimTyConKey = mkPreludeTyConUnique 22
-mallocPtrTyConKey = mkPreludeTyConUnique 23
-mutableArrayPrimTyConKey = mkPreludeTyConUnique 24
---UNUSED:mutableArrayTyConKey = mkPreludeTyConUnique 25
-mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 26
---UNUSED:mutableByteArrayTyConKey = mkPreludeTyConUnique 27
---UNUSED:packedStringTyConKey = mkPreludeTyConUnique 28
-synchVarPrimTyConKey = mkPreludeTyConUnique 29
-ratioTyConKey = mkPreludeTyConUnique 30
-rationalTyConKey = mkPreludeTyConUnique 31
-realWorldTyConKey = mkPreludeTyConUnique 32
---UNUSED:requestTyConKey = mkPreludeTyConUnique 33
---UNUSED:responseTyConKey = mkPreludeTyConUnique 34
-return2GMPsTyConKey = mkPreludeTyConUnique 35
-returnIntAndGMPTyConKey = mkPreludeTyConUnique 36
---UNUSED:seqIntPrimTyConKey = mkPreludeTyConUnique 37
---UNUSED:seqTyConKey = mkPreludeTyConUnique 38
-stablePtrPrimTyConKey = mkPreludeTyConUnique 39
-stablePtrTyConKey = mkPreludeTyConUnique 40
-stateAndAddrPrimTyConKey = mkPreludeTyConUnique 41
-stateAndArrayPrimTyConKey = mkPreludeTyConUnique 42
-stateAndByteArrayPrimTyConKey = mkPreludeTyConUnique 43
-stateAndCharPrimTyConKey = mkPreludeTyConUnique 44
-stateAndDoublePrimTyConKey = mkPreludeTyConUnique 45
-stateAndFloatPrimTyConKey = mkPreludeTyConUnique 46
-stateAndIntPrimTyConKey = mkPreludeTyConUnique 47
-stateAndMallocPtrPrimTyConKey = mkPreludeTyConUnique 48
-stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 49
-stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 50
-stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 51
-stateAndPtrPrimTyConKey = mkPreludeTyConUnique 52
-stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 53
-stateAndWordPrimTyConKey = mkPreludeTyConUnique 54
-statePrimTyConKey = mkPreludeTyConUnique 55
-stateTyConKey = mkPreludeTyConUnique 56
-stringTyConKey = mkPreludeTyConUnique 57
-stTyConKey = mkPreludeTyConUnique 58
-primIoTyConKey = mkPreludeTyConUnique 59
---UNUSED:ioResultTyConKey = mkPreludeTyConUnique 60
-voidPrimTyConKey = mkPreludeTyConUnique 61
-wordPrimTyConKey = mkPreludeTyConUnique 62
-wordTyConKey = mkPreludeTyConUnique 63
-
-#ifdef DPH
-podTyConKey = mkPreludeTyConUnique 64
-interfacePodTyConKey = mkPreludeTyConUnique 65
-
-podizedPodTyConKey _ = panic "ToDo:DPH:podizedPodTyConKey"
-#endif {- Data Parallel Haskell -}
+doublePrimTyConKey = mkPreludeTyConUnique 9
+doubleTyConKey = mkPreludeTyConUnique 10
+floatPrimTyConKey = mkPreludeTyConUnique 11
+floatTyConKey = mkPreludeTyConUnique 12
+funTyConKey = mkPreludeTyConUnique 13
+iOTyConKey = mkPreludeTyConUnique 14
+intPrimTyConKey = mkPreludeTyConUnique 15
+intTyConKey = mkPreludeTyConUnique 16
+integerTyConKey = mkPreludeTyConUnique 17
+liftTyConKey = mkPreludeTyConUnique 18
+listTyConKey = mkPreludeTyConUnique 19
+mallocPtrPrimTyConKey = mkPreludeTyConUnique 20
+mallocPtrTyConKey = mkPreludeTyConUnique 21
+mutableArrayPrimTyConKey = mkPreludeTyConUnique 22
+mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 23
+orderingTyConKey = mkPreludeTyConUnique 24
+synchVarPrimTyConKey = mkPreludeTyConUnique 25
+ratioTyConKey = mkPreludeTyConUnique 26
+rationalTyConKey = mkPreludeTyConUnique 27
+realWorldTyConKey = mkPreludeTyConUnique 28
+return2GMPsTyConKey = mkPreludeTyConUnique 29
+returnIntAndGMPTyConKey = mkPreludeTyConUnique 30
+stablePtrPrimTyConKey = mkPreludeTyConUnique 31
+stablePtrTyConKey = mkPreludeTyConUnique 32
+stateAndAddrPrimTyConKey = mkPreludeTyConUnique 33
+stateAndArrayPrimTyConKey = mkPreludeTyConUnique 34
+stateAndByteArrayPrimTyConKey = mkPreludeTyConUnique 35
+stateAndCharPrimTyConKey = mkPreludeTyConUnique 36
+stateAndDoublePrimTyConKey = mkPreludeTyConUnique 37
+stateAndFloatPrimTyConKey = mkPreludeTyConUnique 38
+stateAndIntPrimTyConKey = mkPreludeTyConUnique 39
+stateAndMallocPtrPrimTyConKey = mkPreludeTyConUnique 40
+stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 41
+stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 42
+stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 43
+stateAndPtrPrimTyConKey = mkPreludeTyConUnique 44
+stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 45
+stateAndWordPrimTyConKey = mkPreludeTyConUnique 46
+statePrimTyConKey = mkPreludeTyConUnique 47
+stateTyConKey = mkPreludeTyConUnique 48
+stringTyConKey = mkPreludeTyConUnique 49
+stTyConKey = mkPreludeTyConUnique 50
+primIoTyConKey = mkPreludeTyConUnique 51
+voidPrimTyConKey = mkPreludeTyConUnique 52
+wordPrimTyConKey = mkPreludeTyConUnique 53
+wordTyConKey = mkPreludeTyConUnique 54
\end{code}
%************************************************************************
\begin{code}
addrDataConKey = mkPreludeDataConUnique 1
buildDataConKey = mkPreludeDataConUnique 2
---UNUSED:byteArrayDataConKey = mkPreludeDataConUnique 3
charDataConKey = mkPreludeDataConUnique 4
consDataConKey = mkPreludeDataConUnique 5
doubleDataConKey = mkPreludeDataConUnique 6
-eqTagDataConKey = mkPreludeDataConUnique 7
+eqDataConKey = mkPreludeDataConUnique 7
falseDataConKey = mkPreludeDataConUnique 8
floatDataConKey = mkPreludeDataConUnique 9
-gtTagDataConKey = mkPreludeDataConUnique 10
+gtDataConKey = mkPreludeDataConUnique 10
intDataConKey = mkPreludeDataConUnique 11
integerDataConKey = mkPreludeDataConUnique 12
liftDataConKey = mkPreludeDataConUnique 13
-ltTagDataConKey = mkPreludeDataConUnique 14
+ltDataConKey = mkPreludeDataConUnique 14
mallocPtrDataConKey = mkPreludeDataConUnique 15
---UNUSED:mutableArrayDataConKey = mkPreludeDataConUnique 16
---UNUSED:mutableByteArrayDataConKey = mkPreludeDataConUnique 17
nilDataConKey = mkPreludeDataConUnique 18
---UNUSED:psDataConKey = mkPreludeDataConUnique 19
---UNUSED:cpsDataConKey = mkPreludeDataConUnique 20
ratioDataConKey = mkPreludeDataConUnique 21
return2GMPsDataConKey = mkPreludeDataConUnique 22
returnIntAndGMPDataConKey = mkPreludeDataConUnique 23
stateDataConKey = mkPreludeDataConUnique 39
trueDataConKey = mkPreludeDataConUnique 40
wordDataConKey = mkPreludeDataConUnique 41
-
-#ifdef DPH
-interfacePodDataConKey = mkPreludeDataConUnique 42
-#endif {- Data Parallel Haskell -}
\end{code}
%************************************************************************
%* *
%************************************************************************
-First, for raw @PrimOps@ and their boxed versions:
-\begin{code}
-mkPrimOpIdUnique :: PrimOp -> Unique
-
-mkPrimOpIdUnique op = mkUnique '5' IBOX((tagOf_PrimOp op))
-\end{code}
-
-Now for other non-@DataCon@ @Ids@:
\begin{code}
absentErrorIdKey = mkPreludeMiscIdUnique 1
appendIdKey = mkPreludeMiscIdUnique 2
-augmentIdKey = mkPreludeMiscIdUnique 3
+augmentIdKey = mkPreludeMiscIdUnique 3
buildIdKey = mkPreludeMiscIdUnique 4
errorIdKey = mkPreludeMiscIdUnique 5
foldlIdKey = mkPreludeMiscIdUnique 6
foldrIdKey = mkPreludeMiscIdUnique 7
-forkIdKey = mkPreludeMiscIdUnique 8
+forkIdKey = mkPreludeMiscIdUnique 8
int2IntegerIdKey = mkPreludeMiscIdUnique 9
integerMinusOneIdKey = mkPreludeMiscIdUnique 10
integerPlusOneIdKey = mkPreludeMiscIdUnique 11
packCStringIdKey = mkPreludeMiscIdUnique 14
parErrorIdKey = mkPreludeMiscIdUnique 15
parIdKey = mkPreludeMiscIdUnique 16
-patErrorIdKey = mkPreludeMiscIdUnique 25
---NO:rangeComplaintIdKey = mkPreludeMiscIdUnique 17
+patErrorIdKey = mkPreludeMiscIdUnique 17
realWorldPrimIdKey = mkPreludeMiscIdUnique 18
runSTIdKey = mkPreludeMiscIdUnique 19
seqIdKey = mkPreludeMiscIdUnique 20
unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24
unpackCStringIdKey = mkPreludeMiscIdUnique 25
voidPrimIdKey = mkPreludeMiscIdUnique 26
+mainIdKey = mkPreludeMiscIdUnique 27
+mainPrimIOIdKey = mkPreludeMiscIdUnique 28
#ifdef GRAN
-parLocalIdKey = mkPreludeMiscIdUnique 27
-parGlobalIdKey = mkPreludeMiscIdUnique 28
-noFollowIdKey = mkPreludeMiscIdUnique 29
-copyableIdKey = mkPreludeMiscIdUnique 30
-#endif
-
-#ifdef DPH
-podSelectorIdKey = mkPreludeMiscIdUnique 31
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniqueSupply-type]{@UniqueSupply@ type and operations}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef __GLASGOW_HASKELL__
-data UniqueSupply
- = MkUniqueSupply Int#
- | MkNewSupply SplitUniqSupply
-
-#else
-data UniqueSupply
- = MkUniqueSupply Word{-#STRICT#-}
- | MkNewSupply SplitUniqSupply
-#endif
-\end{code}
-
-@mkUniqueSupply@ is used to get a @UniqueSupply@ started.
-\begin{code}
-mkUniqueSupply :: Char -> UniqueSupply
-
-#ifdef __GLASGOW_HASKELL__
-
-mkUniqueSupply (MkChar c#)
- = MkUniqueSupply (w2i ((i2w (ord# c#)) `shiftL#` (i2w_s 24#)))
-
-#else
-
-mkUniqueSupply c
- = MkUniqueSupply ((fromInt (ord c)) `bitLsh` 24)
-
-#endif
-
-mkUniqueSupplyGrimily s = MkNewSupply s
-\end{code}
-
-The basic operation on a @UniqueSupply@ is to get a @Unique@ (or a
-few). It's just plain different when splittable vs.~not...
-\begin{code}
-getUnique :: UniqueSupply -> (UniqueSupply, Unique)
-
-getUnique (MkUniqueSupply n)
-#ifdef __GLASGOW_HASKELL__
- = (MkUniqueSupply (n +# 1#), MkUnique n)
-#else
- = (MkUniqueSupply (n + 1), MkUnique n)
-#endif
-getUnique (MkNewSupply s)
- = let
- (u, s1) = getSUniqueAndDepleted s
- in
- (MkNewSupply s1, u)
-
-getUniques :: Int -- how many you want
- -> UniqueSupply
- -> (UniqueSupply, [Unique])
-
-#ifdef __GLASGOW_HASKELL__
-getUniques i@(MkInt i#) (MkUniqueSupply n)
- = (MkUniqueSupply (n +# i#),
- [ case x of { MkInt x# ->
- MkUnique (n +# x#) } | x <- [0 .. i-1] ])
-#else
-getUniques i (MkUniqueSupply n)
- = (MkUniqueSupply (n + fromInt i), [ MkUnique (n + fromInt x) | x <- [0 .. i-1] ])
-#endif
-getUniques i (MkNewSupply s)
- = let
- (us, s1) = getSUniquesAndDepleted i s
- in
- (MkNewSupply s1, us)
-\end{code}
-
-[OLD-ish NOTE] Simon says: The last line is preferable over @(n+i,
-<mumble> [n .. (n+i-1)])@, because it is a little lazier. If n=bot
-you get ([bot, bot, bot], bot) back instead of (bot,bot). This is
-sometimes important for knot-tying.
-
-Alternatively, if you hate the inefficiency:
-\begin{pseudocode}
-(range 0, n+i) where range m | m=i = []
- range m = n+m : range (m+1)
-\end{pseudocode}
-
-%************************************************************************
-%* *
-\subsection[UniqueSupplies-compiler]{@UniqueSupplies@ specific to the compiler}
-%* *
-%************************************************************************
-
-Different parts of the compiler have their own @UniqueSupplies@, each
-identified by their ``tag letter:''
-\begin{verbatim}
- B builtin; for when the compiler conjures @Uniques@ out of
- thin air
- b a second builtin; we need two in mkWrapperUnfolding (False)
- r renamer
- t typechecker
- d desugarer
- p ``podizer'' (DPH only)
- s core-to-core simplifier
- S ``pod'' simplifier (DPH only)
- c core-to-stg
- T stg-to-stg simplifier
- f flattener (of abstract~C)
- L Assembly labels (for native-code generators)
- u Printing out unfoldings (so don't have constant renaming)
- P profiling (finalCCstg)
-
- v used in specialised TyVarUniques (see TyVar.lhs)
-
- 1-9 used for ``prelude Uniques'' (wired-in things; see below)
- 1 = classes
- 2 = tycons
- 3 = data cons
- 4 = tuple datacons
- 5 = unboxed-primop ids
- 6 = boxed-primop ids
- 7 = misc ids
-\end{verbatim}
-
-\begin{code}
-uniqSupply_r = mkUniqueSupply 'r'
-uniqSupply_t = mkUniqueSupply 't'
-uniqSupply_d = mkUniqueSupply 'd'
-uniqSupply_p = mkUniqueSupply 'p'
-uniqSupply_s = mkUniqueSupply 's'
-uniqSupply_S = mkUniqueSupply 'S'
-uniqSupply_c = mkUniqueSupply 'c'
-uniqSupply_T = mkUniqueSupply 'T'
-uniqSupply_f = mkUniqueSupply 'f'
-uniqSupply_L = mkUniqueSupply 'L'
-uniqSupply_u = mkUniqueSupply 'u'
-uniqSupply_P = mkUniqueSupply 'P'
-\end{code}
-
-The ``builtin UniqueSupplies'' are more magical. You don't use the
-supply, you ask for @Uniques@ directly from it. (They probably aren't
-unique, but you know that!)
-
-\begin{code}
-uniqSupply_B = mkUniqueSupply 'B' -- not exported!
-uniqSupply_b = mkUniqueSupply 'b' -- not exported!
-\end{code}
-
-\begin{code}
-mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
- mkBuiltinUnique :: Int -> Unique
-
-mkBuiltinUnique i = mkUnique 'B' i
-mkPseudoUnique1 i = mkUnique 'C' i -- used for getTheUnique on Regs
-mkPseudoUnique2 i = mkUnique 'D' i -- ditto
-mkPseudoUnique3 i = mkUnique 'E' i -- ditto
-
-getBuiltinUniques :: Int -> [Unique]
-getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
-\end{code}
-
-The following runs a uniq monad expression, using builtin uniq values:
-\begin{code}
-runBuiltinUs :: UniqSM a -> a
-runBuiltinUs m = snd (initUs uniqSupply_B m)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Unique-monad]{Unique supply monad}
-%* *
-%************************************************************************
-
-A very plain unique-supply monad.
-
-\begin{code}
-type UniqSM result = UniqueSupply -> (UniqueSupply, result)
-
--- the initUs function also returns the final UniqueSupply
-
-initUs :: UniqueSupply -> UniqSM a -> (UniqueSupply, a)
-
-initUs init_us m = m init_us
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenUs #-}
-{-# INLINE returnUs #-}
+parLocalIdKey = mkPreludeMiscIdUnique 29
+parGlobalIdKey = mkPreludeMiscIdUnique 30
+noFollowIdKey = mkPreludeMiscIdUnique 31
+copyableIdKey = mkPreludeMiscIdUnique 32
#endif
\end{code}
-@thenUs@ is are where we split the @UniqueSupply@.
-\begin{code}
-thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
-
-thenUs expr cont us
- = case (expr us) of
- (us1, result) -> cont result us1
+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 33
+fromIntegerClassOpKey = mkPreludeMiscIdUnique 34
+fromRationalClassOpKey = mkPreludeMiscIdUnique 35
+enumFromClassOpKey = mkPreludeMiscIdUnique 36
+enumFromThenClassOpKey = mkPreludeMiscIdUnique 37
+enumFromToClassOpKey = mkPreludeMiscIdUnique 38
+enumFromThenToClassOpKey= mkPreludeMiscIdUnique 39
+eqClassOpKey = mkPreludeMiscIdUnique 40
+geClassOpKey = mkPreludeMiscIdUnique 41
+negateClassOpKey = mkPreludeMiscIdUnique 42
\end{code}
-\begin{code}
-returnUs :: a -> UniqSM a
-returnUs result us = (us, result)
-
-mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b]
-mapUs f [] = returnUs []
-mapUs f (x:xs)
- = f x `thenUs` \ r ->
- mapUs f xs `thenUs` \ rs ->
- returnUs (r:rs)
-mapAndUnzipUs :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c])
-mapAndUnzipUs f [] = returnUs ([],[])
-mapAndUnzipUs f (x:xs)
- = f x `thenUs` \ (r1, r2) ->
- mapAndUnzipUs f xs `thenUs` \ (rs1, rs2) ->
- returnUs (r1:rs1, r2:rs2)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgBindery where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo, LambdaFormInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data AbstractC
-data CAddrMode
-data MagicId
-data BasicLit
-data CLabel
-type CgBindings = UniqFM CgIdInfo
-data CgIdInfo = MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo
-data CgState
-data LambdaFormInfo
-data HeapOffset
-data Id
-type IdEnv a = UniqFM a
-data Labda a
-data StableLoc
-data StgAtom a
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-data VolatileLoc
-bindArgsToRegs :: [Id] -> [MagicId] -> CgInfoDownwards -> CgState -> CgState
-bindNewPrimToAmode :: Id -> CAddrMode -> CgInfoDownwards -> CgState -> CgState
-bindNewToAStack :: (Id, Int) -> CgInfoDownwards -> CgState -> CgState
-bindNewToBStack :: (Id, Int) -> CgInfoDownwards -> CgState -> CgState
-bindNewToNode :: Id -> HeapOffset -> LambdaFormInfo -> CgInfoDownwards -> CgState -> CgState
-bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> CgInfoDownwards -> CgState -> CgState
-bindNewToTemp :: Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-getAtomAmode :: StgAtom Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-getAtomAmodes :: [StgAtom Id] -> CgInfoDownwards -> CgState -> ([CAddrMode], CgState)
-getCAddrMode :: Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-getCAddrModeAndInfo :: Id -> CgInfoDownwards -> CgState -> ((CAddrMode, LambdaFormInfo), CgState)
-getCAddrModeIfVolatile :: Id -> CgInfoDownwards -> CgState -> (Labda CAddrMode, CgState)
-getVolatileRegs :: UniqFM Id -> CgInfoDownwards -> CgState -> ([MagicId], CgState)
-heapIdInfo :: Id -> HeapOffset -> LambdaFormInfo -> CgIdInfo
-idInfoToAmode :: PrimKind -> CgIdInfo -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-letNoEscapeIdInfo :: Id -> Int -> Int -> LambdaFormInfo -> CgIdInfo
-maybeAStkLoc :: StableLoc -> Labda Int
-maybeBStkLoc :: StableLoc -> Labda Int
-newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
-nukeVolatileBinds :: UniqFM CgIdInfo -> UniqFM CgIdInfo
-rebindToAStack :: Id -> Int -> CgInfoDownwards -> CgState -> CgState
-rebindToBStack :: Id -> Int -> CgInfoDownwards -> CgState -> CgState
-stableAmodeIdInfo :: Id -> CAddrMode -> LambdaFormInfo -> CgIdInfo
-
bindNewToAStack, bindNewToBStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
---UNUSED: bindNewToSameAsOther,
bindNewToTemp, bindNewPrimToAmode,
getAtomAmode, getAtomAmodes,
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
- rebindToAStack, rebindToBStack,
---UNUSED: rebindToTemp,
+ rebindToAStack, rebindToBStack
-- and to make a self-sufficient interface...
- AbstractC, CAddrMode, HeapOffset, MagicId, CLabel, CgState,
- BasicLit, IdEnv(..), UniqFM,
- Id, Maybe, Unique, StgAtom, UniqSet(..)
) where
-IMPORT_Trace -- ToDo: rm (debugging only)
-import Outputable
-import Unpretty
-import PprAbsC
-
import AbsCSyn
import CgMonad
import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
-import CLabelInfo ( mkClosureLabel, CLabel )
+import CLabel ( mkClosureLabel, CLabel )
import ClosureInfo
-import Id ( getIdKind, toplevelishId, isDataCon, Id )
-import IdEnv -- used to build CgBindings
+import Id ( getIdPrimRep, toplevelishId, isDataCon, Id )
import Maybes ( catMaybes, Maybe(..) )
import UniqSet -- ( setToList )
import StgSyn
= NoStableLoc
| VirAStkLoc VirtualSpAOffset
| VirBStkLoc VirtualSpBOffset
- | LitLoc BasicLit
+ | LitLoc Literal
| StableAmodeLoc CAddrMode
-- these are so StableLoc can be abstract:
newTempAmodeAndIdInfo name lf_info
= (temp_amode, temp_idinfo)
where
- uniq = getTheUnique name
- temp_amode = CTemp uniq (getIdKind name)
+ uniq = getItsUnique name
+ temp_amode = CTemp uniq (getIdPrimRep name)
temp_idinfo = tempIdInfo name uniq lf_info
idInfoToAmode :: PrimKind -> CgIdInfo -> FCode CAddrMode
= getSpBRelOffset i `thenFC` \ rel_spB ->
returnFC (CVal rel_spB kind)
+#ifdef DEBUG
idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc"
+#endif
\end{code}
%************************************************************************
returnFC (amode, lf_info)
where
global_amode = CLbl (mkClosureLabel name) kind
- kind = getIdKind name
+ kind = getIdPrimRep name
getCAddrMode :: Id -> FCode CAddrMode
getCAddrMode name
= lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
case stable_loc of
NoStableLoc -> -- Aha! So it is volatile!
- idInfoPiecesToAmode (getIdKind name) volatile_loc NoStableLoc `thenFC` \ amode ->
+ idInfoPiecesToAmode (getIdPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
returnFC (Just amode)
a_stable_loc -> returnFC Nothing
forget the volatile one.
\begin{code}
-getVolatileRegs :: PlainStgLiveVars -> FCode [MagicId]
+getVolatileRegs :: StgLiveVars -> FCode [MagicId]
getVolatileRegs vars
= mapFCs snaffle_it (uniqSetToList vars) `thenFC` \ stuff ->
let
-- commoned-up code...
consider_reg reg
- = if not (isVolatileReg reg) then
+ = if not (isVolatileReg reg) then
-- Potentially dies across C calls
-- For now, that's everything; we leave
-- it to the save-macros to decide which
else
case stable_loc of
NoStableLoc -> returnFC (Just reg) -- got one!
- is_a_stable_loc ->
+ is_a_stable_loc ->
-- has both volatile & stable locations;
-- force it to rely on the stable location
modifyBindC var nuke_vol_bind `thenC`
\end{code}
\begin{code}
-getAtomAmodes :: [PlainStgAtom] -> FCode [CAddrMode]
+getAtomAmodes :: [StgArg] -> FCode [CAddrMode]
getAtomAmodes [] = returnFC []
getAtomAmodes (atom:atoms)
= getAtomAmode atom `thenFC` \ amode ->
getAtomAmodes atoms `thenFC` \ amodes ->
returnFC ( amode : amodes )
-getAtomAmode :: PlainStgAtom -> FCode CAddrMode
+getAtomAmode :: StgArg -> FCode CAddrMode
-getAtomAmode (StgVarAtom var) = getCAddrMode var
-getAtomAmode (StgLitAtom lit) = returnFC (CLit lit)
+getAtomAmode (StgVarArg var) = getCAddrMode var
+getAtomAmode (StgLitArg lit) = returnFC (CLit lit)
\end{code}
%************************************************************************
bindArgsToRegs :: [Id] -> [MagicId] -> Code
bindArgsToRegs args regs
- = listCs (zipWith bind args regs)
- where
- arg `bind` reg = bindNewToReg arg reg mkLFArgument
-
-{- UNUSED:
-bindNewToSameAsOther :: Id -> PlainStgAtom -> Code
-bindNewToSameAsOther name (StgVarAtom old_name)
-#ifdef DEBUG
- | toplevelishId old_name = panic "bindNewToSameAsOther: global old name"
- | otherwise
-#endif
- = lookupBindC old_name `thenFC` \ old_stuff ->
- addBindC name old_stuff
-
-bindNewToSameAsOther name (StgLitAtom lit)
- = addBindC name info
+ = listCs (zipWithEqual bind args regs)
where
- info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (panic "bindNewToSameAsOther")
--}
+ arg `bind` reg = bindNewToReg arg reg mkLFArgument
\end{code}
@bindNewPrimToAmode@ works only for certain addressing modes, because
bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit
-bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
+bindNewPrimToAmode name (CVal (SpBRel _ offset) _)
= bindNewToBStack (name, offset)
-bindNewPrimToAmode name (CVal (NodeRel offset) _)
+bindNewPrimToAmode name (CVal (NodeRel offset) _)
= bindNewToNode name offset (panic "bindNewPrimToAmode node")
-- See comment on idInfoPiecesToAmode for VirNodeLoc
where
replace_stable_fn (MkCgIdInfo i vol stab einfo)
= MkCgIdInfo i vol (VirBStkLoc offset) einfo
-
-{- UNUSED:
-rebindToTemp :: Id -> FCode CAddrMode
-rebindToTemp name
- = let
- (temp_amode, MkCgIdInfo _ new_vol _ _ {-LF info discarded-})
- = newTempAmodeAndIdInfo name (panic "rebindToTemp")
- in
- modifyBindC name (replace_volatile_fn new_vol) `thenC`
- returnFC temp_amode
- where
- replace_volatile_fn new_vol (MkCgIdInfo i vol stab einfo)
- = MkCgIdInfo i new_vol stab einfo
--}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgCase where
-import AbsCSyn(AbstractC)
-import BasicLit(BasicLit)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, EndOfBlockInfo, StubFlag)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgCaseDefault, StgExpr)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CgState
-data Id
-data StgCaseAlternatives a b
-data StgExpr a b
-cgCase :: StgExpr Id Id -> UniqFM Id -> UniqFM Id -> Unique -> StgCaseAlternatives Id Id -> CgInfoDownwards -> CgState -> CgState
-saveVolatileVarsAndRegs :: UniqFM Id -> CgInfoDownwards -> CgState -> ((AbstractC, EndOfBlockInfo, Labda Int), CgState)
-
module CgCase (
cgCase,
- saveVolatileVarsAndRegs,
+ saveVolatileVarsAndRegs
-- and to make the interface self-sufficient...
- StgExpr, Id, StgCaseAlternatives, CgState
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty
-
import StgSyn
import CgMonad
import AbsCSyn
-import AbsPrel ( PrimOp(..), primOpCanTriggerGC
+import PrelInfo ( PrimOp(..), primOpCanTriggerGC
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( kindFromType, getTyConDataCons,
+import Type ( primRepFromType, getTyConDataCons,
getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
isEnumerationTyCon,
- UniType
+ Type
)
import CgBindery -- all of it
import CgCon ( buildDynCon, bindConArgs )
import CgStackery -- plenty
import CgTailCall ( tailCallBusiness, performReturn )
import CgUsages -- and even more
-import CLabelInfo -- bunches of things...
+import CLabel -- bunches of things...
import ClosureInfo {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument,
layOutDynCon
)-}
-import CmdLineOpts ( GlobalSwitch(..) )
import CostCentre ( useCurrentCostCentre, CostCentre )
-import BasicLit ( kindOfBasicLit )
-import Id ( getDataConTag, getIdKind, fIRST_TAG, isDataCon,
+import Literal ( literalPrimRep )
+import Id ( getDataConTag, getIdPrimRep, fIRST_TAG, isDataCon,
toplevelishId, getInstantiatedDataConSig,
ConTag(..), DataCon(..)
)
import Maybes ( catMaybes, Maybe(..) )
-import PrimKind ( getKindSize, isFollowableKind, retKindSize, PrimKind(..) )
+import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, PrimRep(..) )
import UniqSet -- ( uniqSetToList, UniqSet(..) )
import Util
\end{code}
It is quite interesting to decide whether to put a heap-check
at the start of each alternative. Of course we certainly have
to do so if the case forces an evaluation, or if there is a primitive
-op which can trigger GC.
+op which can trigger GC.
A more interesting situation is this:
\begin{itemize}
\item
-{\em May} save a heap overflow test,
+{\em May} save a heap overflow test,
if ...A... allocates anything. The other advantage
of this is that we can use relative addressing
from a single Hp to get at all the closures so allocated.
\end{itemize}
Against:
-
+
\begin{itemize}
\item
May do more allocation than reqd. This sometimes bites us
\tr{!C!} without a full save-volatile-vars sequence.
\begin{code}
-cgCase :: PlainStgExpr
- -> PlainStgLiveVars
- -> PlainStgLiveVars
+cgCase :: StgExpr
+ -> StgLiveVars
+ -> StgLiveVars
-> Unique
- -> PlainStgCaseAlternatives
+ -> StgCaseAlts
-> Code
\end{code}
**** END OF TO DO TO DO
\begin{code}
-cgCase scrut@(StgPrimApp op args _) live_in_whole_case live_in_alts uniq
+cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
(StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
= if not (null alts) then
panic "cgCase: case on PrimOp with default *and* alts\n"
where
scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
Updatable [] scrut
- scrut_free_vars = [ fv | StgVarAtom fv <- args, not (toplevelishId fv) ]
+ scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
-- Hack, hack
\end{code}
\begin{code}
-cgCase (StgPrimApp op args _) live_in_whole_case live_in_alts uniq alts
+cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
| not (primOpCanTriggerGC op)
=
-- Get amodes for the arguments and results
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+ getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
let
result_amodes = getPrimAppResultAmodes uniq alts
liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
op_result_amodes = map CReg op_result_regs
- (op_arg_amodes, liveness_mask, arg_assts)
+ (op_arg_amodes, liveness_mask, arg_assts)
= makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
liveness_arg = mkIntCLit liveness_mask
saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
getEndOfBlockInfo `thenFC` \ eob_info ->
- forkEval eob_info nopC
+ forkEval eob_info nopC
(getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
- absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
+ absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
`thenC`
- returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
- Nothing{-no semi-tagging-}))
+ returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
+ Nothing{-no semi-tagging-}))
`thenFC` \ new_eob_info ->
-- Record the continuation info
setEndOfBlockInfo new_eob_info (
- -- Now "return" to the inline alternatives; this will get
+ -- Now "return" to the inline alternatives; this will get
-- compiled to a fall-through.
let
simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
-
+
-- do_op_and_continue will be passed an amode for the continuation
do_op_and_continue sequel
- = absC (COpStmt op_result_amodes
+ = absC (COpStmt op_result_amodes
op
(pin_liveness op liveness_arg op_arg_amodes)
liveness_mask
[{-no vol_regs-}])
`thenC`
- sequelToAmode sequel `thenFC` \ dest_amode ->
- absC (CReturn dest_amode DirectReturn)
+ sequelToAmode sequel `thenFC` \ dest_amode ->
+ absC (CReturn dest_amode DirectReturn)
-- Note: we CJump even for algebraic data types,
-- because cgInlineAlts always generates code, never a
we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
-cgCase (StgApp (StgVarAtom fun) args _ {-lvs must be same as live_in_alts-})
- live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
+cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
+ live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
=
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
getAtomAmodes args `thenFC` \ arg_amodes ->
-- Squish the environment
nukeDeadBindings live_in_alts `thenC`
- saveVolatileVarsAndRegs live_in_alts
+ saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
forkEval alts_eob_info
saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
- -- Save those variables right now!
+ -- Save those variables right now!
absC save_assts `thenC`
- forkEval alts_eob_info
+ forkEval alts_eob_info
(nukeDeadBindings live_in_alts)
(cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
\begin{code}
getPrimAppResultAmodes
:: Unique
- -> PlainStgCaseAlternatives
+ -> StgCaseAlts
-> [CAddrMode]
\end{code}
where
-- A temporary variable to hold the tag; this is unaffected by GC because
-- the heap-checks in the branches occur after the switch
- tag_amode = CTemp uniq IntKind
+ tag_amode = CTemp uniq IntRep
(spec_tycon, _, _) = getUniDataSpecTyCon ty
getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
where
-- A temporary variable to hold the tag; this is unaffected by GC because
-- the heap-checks in the branches occur after the switch
- tag_amode = CTemp uniq IntKind
+ tag_amode = CTemp uniq IntRep
-- Sort alternatives into canonical order; there must be a complete
-- set because there's no default case.
-- Turn them into amodes
arg_amodes = concat (map mk_amodes sorted_alts)
mk_amodes (con, args, use_mask, rhs)
- = [ CTemp (getTheUnique arg) (getIdKind arg) | arg <- args ]
+ = [ CTemp (getItsUnique arg) (getIdPrimRep arg) | arg <- args ]
\end{code}
The situation is simpler for primitive
getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
= [CTemp uniq kind]
where
- kind = kindFromType ty
+ kind = primRepFromType ty
\end{code}
\begin{code}
cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
-> Unique
- -> PlainStgCaseAlternatives
+ -> StgCaseAlts
-> FCode Sequel -- Any addr modes inside are guaranteed to be a label
-- so that we can duplicate it without risk of
-- duplicating code
let
(spec_tycon, _, _) = getUniDataSpecTyCon ty
- use_labelled_alts
+ use_labelled_alts
= case ctrlReturnConvAlg spec_tycon of
VectoredReturn _ -> True
_ -> False
getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
-- Generate the labelled block, starting with restore-cost-centre
- absC (CRetUnVector vtbl_label
- (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
+ absC (CRetUnVector vtbl_label
+ (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
`thenC`
-- Return an amode for the block
returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
\begin{code}
cgInlineAlts :: GCFlag -> Unique
- -> PlainStgCaseAlternatives
+ -> StgCaseAlts
-> Code
\end{code}
where
-- A temporary variable to hold the tag; this is unaffected by GC because
-- the heap-checks in the branches occur after the switch
- tag_amode = CTemp uniq IntKind
-\end{code}
-
-=========== OLD: we *can* now handle this case ================
-
-Next, a case we can't deal with: an algebraic case with no evaluation
-required (so it is in-line), and a default case as well. In this case
-we require all the alternatives written out, so that we can invent
-suitable binders to pass to the PrimOp. A default case defeats this.
-Could be fixed, but probably isn't worth it.
-
-\begin{code}
-{- ============= OLD
-cgInlineAlts gc_flag uniq (StgAlgAlts ty alts other_default)
- = panic "cgInlineAlts: alg alts with default"
-================= END OF OLD -}
+ tag_amode = CTemp uniq IntRep
\end{code}
Third (real) case: primitive result type.
-> Unique
-> AbstractC -- Restore-cost-centre instruction
-> Bool -- True <=> branches must be labelled
- -> UniType -- From the case statement
- -> [(Id, [Id], [Bool], PlainStgExpr)] -- The alternatives
- -> PlainStgCaseDefault -- The default
+ -> Type -- From the case statement
+ -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
+ -> StgCaseDefault -- The default
-> FCode ([(ConTag, AbstractC)], -- The branches
AbstractC -- The default case
)
case.
OLD: All of this only works if a heap-check is required anyway, because
-otherwise it isn't safe to allocate.
+otherwise it isn't safe to allocate.
NEW (July 94): now false! It should work regardless of gc_flag,
because of the extra_branches argument now added to forkAlts.
where
default_join_lbl = mkDefaultLabel uniq
- jump_instruction = CJump (CLbl default_join_lbl CodePtrKind)
+ jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
(spec_tycon, _, spec_cons)
= -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [
alt_cons = [ con | (con,_,_,_) <- alts ]
default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
- spec_con `not_elem` alt_cons ] -- Not handled explicitly
+ spec_con `not_elem` alt_cons ] -- Not handled explicitly
where
not_elem = isn'tIn "cgAlgAlts"
buildDynCon binder useCurrentCostCentre con
(map CReg regs) (all zero_size regs)
`thenFC` \ idinfo ->
- idInfoToAmode PtrKind idinfo `thenFC` \ amode ->
+ idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
absC (CAssign (CReg node) amode) `thenC`
absC jump_instruction
)
where
- zero_size reg = getKindSize (kindFromMagicId reg) == 0
+ zero_size reg = getPrimRepSize (kindFromMagicId reg) == 0
\end{code}
Now comes the general case
\begin{code}
-cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
+cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
{- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
= forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
[{- No "extra branches" -}]
\begin{code}
cgAlgDefault :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state...
- -> PlainStgCaseDefault -- input
+ -> StgCaseDefault -- input
-> FCode AbstractC -- output
cgAlgDefault gc_flag uniq restore_cc must_label_branch
cgAlgAlt :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state
- -> (Id, [Id], [Bool], PlainStgExpr)
+ -> (Id, [Id], [Bool], StgExpr)
-> FCode (ConTag, AbstractC)
cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
= getAbsC (absC restore_cc `thenC`
- cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
+ cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
let
final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
| otherwise = abs_c
tag = getDataConTag con
lbl = mkAltLabel uniq tag
-cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> PlainStgExpr -> Code
+cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
cgAlgAltRhs gc_flag con args use_mask rhs
= getIntSwitchChkrC `thenFC` \ isw_chkr ->
in
possibleHeapCheck gc_flag live_regs node_reqd (
(case gc_flag of
- NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
+ NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
nopC
GCMayHappen -> bindConArgs con args
) `thenC`
- cgExpr rhs
+ cgExpr rhs
)
\end{code}
\begin{code}
cgSemiTaggedAlts :: IntSwitchChecker
-> Unique
- -> [(Id, [Id], [Bool], PlainStgExpr)]
- -> StgCaseDefault Id Id
+ -> [(Id, [Id], [Bool], StgExpr)]
+ -> GenStgCaseDefault Id Id
-> SemiTaggingStuff
cgSemiTaggedAlts isw_chkr uniq alts deflt
used_regs = selectByMask use_mask regs
- used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
+ used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
reg `is_elem` used_regs]
is_elem = isIn "cgSemiTaggedAlts"
\begin{code}
cgPrimAlts :: GCFlag
-> Unique
- -> UniType
- -> [(BasicLit, PlainStgExpr)] -- Alternatives
- -> PlainStgCaseDefault -- Default
+ -> Type
+ -> [(Literal, StgExpr)] -- Alternatives
+ -> StgCaseDefault -- Default
-> Code
cgPrimAlts gc_flag uniq ty alts deflt
NoGC -> CTemp uniq kind
GCMayHappen -> CReg (dataReturnConvPrim kind)
- kind = kindFromType ty
+ kind = primRepFromType ty
cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
cgPrimAlt :: GCFlag
- -> (BasicLit, PlainStgExpr) -- The alternative
- -> FCode (BasicLit, AbstractC) -- Its compiled form
+ -> (Literal, StgExpr) -- The alternative
+ -> FCode (Literal, AbstractC) -- Its compiled form
cgPrimAlt gc_flag (lit, rhs)
= getAbsC rhs_code `thenFC` \ absC ->
cgPrimDefault :: GCFlag
-> CAddrMode -- Scrutinee
- -> PlainStgCaseDefault
+ -> StgCaseDefault
-> FCode AbstractC
cgPrimDefault gc_flag scrutinee StgNoDefault
cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
= getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
where
- regs = if isFollowableKind (getAmodeKind scrutinee) then
+ regs = if isFollowableRep (getAmodeRep scrutinee) then
[node] else []
rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
\begin{code}
saveVolatileVarsAndRegs
- :: PlainStgLiveVars -- Vars which should be made safe
+ :: StgLiveVars -- Vars which should be made safe
-> FCode (AbstractC, -- Assignments to do the saves
EndOfBlockInfo, -- New sequel, recording where the return
- -- address now is
+ -- address now is
Maybe VirtualSpBOffset) -- Slot for current cost centre
saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
- new_eob_info,
- maybe_cc_slot)
+ new_eob_info,
+ maybe_cc_slot)
-saveVolatileVars :: PlainStgLiveVars -- Vars which should be made safe
+saveVolatileVars :: StgLiveVars -- Vars which should be made safe
-> FCode AbstractC -- Assignments to to the saves
saveVolatileVars vars
= getCAddrModeIfVolatile var `thenFC` \ v ->
case v of
Nothing -> save_em vars -- Non-volatile, so carry on
-
+
Just vol_amode -> -- Aha! It's volatile
save_var var vol_amode `thenFC` \ abs_c ->
returnFC (abs_c `mkAbsCStmts` abs_cs)
save_var var vol_amode
- | isFollowableKind kind
+ | isFollowableRep kind
= allocAStack `thenFC` \ a_slot ->
rebindToAStack var a_slot `thenC`
getSpARelOffset a_slot `thenFC` \ spa_rel ->
returnFC (CAssign (CVal spa_rel kind) vol_amode)
| otherwise
- = allocBStack (getKindSize kind) `thenFC` \ b_slot ->
+ = allocBStack (getPrimRepSize kind) `thenFC` \ b_slot ->
rebindToBStack var b_slot `thenC`
getSpBRelOffset b_slot `thenFC` \ spb_rel ->
returnFC (CAssign (CVal spb_rel kind) vol_amode)
where
- kind = getAmodeKind vol_amode
+ kind = getAmodeRep vol_amode
saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
-saveReturnAddress
+saveReturnAddress
= getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
-- See if it is volatile
case sequel of
InRetReg -> -- Yes, it's volatile
- allocBStack retKindSize `thenFC` \ b_slot ->
- getSpBRelOffset b_slot `thenFC` \ spb_rel ->
+ allocBStack retPrimRepSize `thenFC` \ b_slot ->
+ getSpBRelOffset b_slot `thenFC` \ spb_rel ->
- returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
- CAssign (CVal spb_rel RetKind) (CReg RetReg))
+ returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
+ CAssign (CVal spb_rel RetRep) (CReg RetReg))
UpdateCode _ -> -- It's non-volatile all right, but we still need
-- to allocate a B-stack slot for it, *solely* to make
-- appear adjacent on the B stack. This makes sure
-- that B-stack squeezing works ok.
-- See note below
- allocBStack retKindSize `thenFC` \ b_slot ->
- returnFC (eob_info, AbsCNop)
+ allocBStack retPrimRepSize `thenFC` \ b_slot ->
+ returnFC (eob_info, AbsCNop)
other -> -- No, it's non-volatile, so do nothing
- returnFC (eob_info, AbsCNop)
+ returnFC (eob_info, AbsCNop)
\end{code}
Note about B-stack squeezing. Consider the following:`
(b)~the assignment to do the save (just as for @saveVolatileVars@).
\begin{code}
-saveCurrentCostCentre ::
+saveCurrentCostCentre ::
FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
-- Nothing if not lexical CCs
AbstractC) -- Assignment to save it
if not doing_profiling then
returnFC (Nothing, AbsCNop)
else
- allocBStack (getKindSize CostCentreKind) `thenFC` \ b_slot ->
+ allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
getSpBRelOffset b_slot `thenFC` \ spb_rel ->
returnFC (Just b_slot,
- CAssign (CVal spb_rel CostCentreKind) (CReg CurCostCentre))
+ CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
-restoreCurrentCostCentre Nothing
+restoreCurrentCostCentre Nothing
= returnFC AbsCNop
-restoreCurrentCostCentre (Just b_slot)
+restoreCurrentCostCentre (Just b_slot)
= getSpBRelOffset b_slot `thenFC` \ spb_rel ->
freeBStkSlot b_slot `thenC`
- returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreKind])
+ returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
-- we use the RESTORE_CCC macro, rather than just
-- assigning into CurCostCentre, in case RESTORE_CCC
-- has some sanity-checking in it.
\begin{code}
mkReturnVector :: Unique
- -> UniType
+ -> Type
-> [(ConTag, AbstractC)] -- Branch codes
-> AbstractC -- Default case
-> FCode CAddrMode
UnvectoredReturn _ ->
(CUnVecLbl ret_label vtbl_label,
absC (CRetUnVector vtbl_label
- (CLabelledCode ret_label
- (mkAlgAltsCSwitch (CReg TagReg)
- tagged_alt_absCs
- deflt_absC))));
+ (CLabelledCode ret_label
+ (mkAlgAltsCSwitch (CReg TagReg)
+ tagged_alt_absCs
+ deflt_absC))));
VectoredReturn table_size ->
- (CLbl vtbl_label DataPtrKind,
+ (CLbl vtbl_label DataPtrRep,
absC (CRetVector vtbl_label
-- must restore cc before each alt, if required
- (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
+ (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
deflt_absC))
-- Leave nops and comments in for now; they are eliminated
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgClosure where
-import AbsCSyn(AbstractC)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, StubFlag)
-import ClosureInfo(LambdaFormInfo)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgExpr, UpdateFlag)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CgIdInfo
-data CgInfoDownwards
-data CgState
-data CompilationInfo
-data HeapOffset
-data Id
-data Labda a
-data StgExpr a b
-data UpdateFlag
-cgRhsClosure :: Id -> CostCentre -> StgBinderInfo -> [Id] -> [Id] -> StgExpr Id Id -> LambdaFormInfo -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
-cgTopRhsClosure :: Id -> CostCentre -> StgBinderInfo -> [Id] -> StgExpr Id Id -> LambdaFormInfo -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
-
\begin{code}
#include "HsVersions.h"
-module CgClosure (
- cgTopRhsClosure, cgRhsClosure,
-
- -- and to make the interface self-sufficient...
- StgExpr, Id, CgState, Maybe, HeapOffset,
- CgInfoDownwards, CgIdInfo, CompilationInfo,
- UpdateFlag
- ) where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty -- NB: see below
+module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
import StgSyn
import CgMonad
import AbsCSyn
-import AbsPrel ( PrimOp(..), primOpNameInfo, Name
+import PrelInfo ( PrimOp(..), Name
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( isPrimType, isPrimTyCon,
+import Type ( isPrimType, isPrimTyCon,
getTauType, showTypeCategory, getTyConDataCons
- IF_ATTACK_PRAGMAS(COMMA splitType)
- IF_ATTACK_PRAGMAS(COMMA splitTyArgs)
)
import CgBindery ( getCAddrMode, getAtomAmodes,
getCAddrModeAndInfo,
#ifdef GRAN
, heapCheckOnly, fetchAndReschedule -- HWL
#endif {- GRAN -}
- )
+ )
import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask,
CtrlReturnConvention(..), DataReturnConvention(..)
)
getSpARelOffset, getSpBRelOffset,
getHpRelOffset
)
-import CLabelInfo
+import CLabel
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( GlobalSwitch(..) )
import CostCentre
-import Id ( getIdUniType, getIdKind, isSysLocalId, myWrapperMaybe,
+import Id ( idType, getIdPrimRep, isSysLocalId, myWrapperMaybe,
showId, getIdInfo, getIdStrictness,
getDataConTag
)
import IdInfo
import ListSetOps ( minusList )
import Maybes ( Maybe(..), maybeToBool )
-import PrimKind ( isFollowableKind )
+import PrimRep ( isFollowableRep )
import UniqSet
import Unpretty
import Util
-> CostCentre -- Optional cost centre annotation
-> StgBinderInfo
-> [Id] -- Args
- -> PlainStgExpr
+ -> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-\end{code}
-\begin{code}
-{- NOT USED:
-cgTopRhsClosure name cc binder_info args body lf_info
- | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
- = (
- -- LAY OUT THE OBJECT
- getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
- let
- (closure_info, amodes_w_offsets) = layOutStaticClosure name getAmodeKind amodes lf_info
- in
-
- -- BUILD THE OBJECT
- chooseStaticCostCentre cc lf_info `thenFC` \ cost_centre ->
- absC (CStaticClosure
- closure_label -- Labelled with the name on lhs of defn
- closure_info
- cost_centre
- (map fst amodes_w_offsets)) -- They are in the correct order
- ) `thenC`
-
- returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info)
- where
- maybe_std_thunk = getStandardFormThunkInfo lf_info
- Just std_thunk_payload = maybe_std_thunk
-
- closure_label = mkClosureLabel name
--}
-\end{code}
-
-The general case:
-\begin{code}
cgTopRhsClosure name cc binder_info args body lf_info
= -- LAY OUT THE OBJECT
let
closure_info = layOutStaticNoFVClosure name lf_info
in
-
+
-- GENERATE THE INFO TABLE (IF NECESSARY)
- forkClosureBody (closureCodeBody binder_info closure_info
+ forkClosureBody (closureCodeBody binder_info closure_info
cc args body)
`thenC`
else
let
bind_the_fun = addBindC name cg_id_info -- It's global!
- in
+ in
cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
) `thenC`
let
cost_centre = mkCCostCentre cc
in
- absC (CStaticClosure
+ absC (CStaticClosure
closure_label -- Labelled with the name on lhs of defn
closure_info
- cost_centre
+ cost_centre
[]) -- No fields
else
nopC
returnFC (name, cg_id_info)
where
closure_label = mkClosureLabel name
- cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info
+ cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
\end{code}
%********************************************************
-- Closures which (a) have no fvs and (b) have some args (i.e.
-- combinator functions), are allocated statically, just as if they
-- were top-level closures. We can't get a space leak that way
--- (because they are HNFs) and it saves allocation.
+-- (because they are HNFs) and it saves allocation.
-- Lexical Scoping: Problem
-- These top level function closures will be inherited, possibly
-> StgBinderInfo
-> [Id] -- Free vars
-> [Id] -- Args
- -> PlainStgExpr
+ -> StgExpr
-> LambdaFormInfo
-> FCode (Id, CgIdInfo)
getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeKind amodes lf_info
+ = layOutDynClosure binder getAmodeRep amodes lf_info
(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
in
-- BUILD THE OBJECT
allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- )
+ )
`thenFC` \ heap_offset ->
-- RETURN
let
is_elem = isIn "cgRhsClosure"
- binder_is_a_fv = binder `is_elem` fvs
- reduced_fvs = if binder_is_a_fv
- then fvs `minusList` [binder]
- else fvs
+ binder_is_a_fv = binder `is_elem` fvs
+ reduced_fvs = if binder_is_a_fv
+ then fvs `minusList` [binder]
+ else fvs
in
mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
let
amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
- get_kind (id, amode_and_info) = getIdKind id
+ get_kind (id, amode_and_info) = getIdPrimRep id
in
-- BUILD ITS INFO TABLE AND CODE
forkClosureBody (
--
-- If f is not top-level, then f is one of the free variables too,
-- hence "payload_ids" isn't the same as "arg_ids".
- --
- vap_entry_rhs = StgApp (StgVarAtom fun) (map StgVarAtom args) emptyUniqSet
+ --
+ vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyUniqSet
-- Empty live vars
arg_ids_w_info = [(name,mkLFArgument) | name <- args]
payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
- | otherwise = arg_ids_w_info
+ | otherwise = arg_ids_w_info
payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
| otherwise = args
vap_lf_info = mkClosureLFInfo False {-not top level-} payload_ids
- upd_flag [] vap_entry_rhs
+ upd_flag [] vap_entry_rhs
-- It's not top level, even if we're currently compiling a top-level
- -- function, because any VAP *use* of this function will be for a
+ -- function, because any VAP *use* of this function will be for a
-- local thunk, thus
-- let x = f p q -- x isn't top level!
-- in ...
- get_kind (id, info) = getIdKind id
+ get_kind (id, info) = getIdPrimRep id
payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
- (closure_info, payload_bind_details) = layOutDynClosure
- fun
- get_kind payload_ids_w_info
+ (closure_info, payload_bind_details) = layOutDynClosure
+ fun
+ get_kind payload_ids_w_info
vap_lf_info
- -- The dodgy thing is that we use the "fun" as the
+ -- The dodgy thing is that we use the "fun" as the
-- Id to give to layOutDynClosure. This Id gets embedded in
-- the closure_info it returns. But of course, the function doesn't
-- have the right type to match the Vap closure. Never mind,
-> ClosureInfo -- Lots of information about this closure
-> CostCentre -- Optional cost centre attached to closure
-> [Id]
- -> PlainStgExpr
+ -> StgExpr
-> Code
\end{code}
where
cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
- body_addr = CLbl (entryLabelFromCI closure_info) CodePtrKind
+ body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
body_code = profCtrC SLIT("ENT_THK") [] `thenC`
enterCostCentreCode closure_info cc IsThunk `thenC`
thunkWrapper closure_info (cgSccExpr body)
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind
+ stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
\end{code}
If there is {\em at least one argument}, then this closure is in
\begin{code}
closureCodeBody binder_info closure_info cc all_args body
= getEntryConvention id lf_info
- (map getIdKind all_args) `thenFC` \ entry_conv ->
+ (map getIdPrimRep all_args) `thenFC` \ entry_conv ->
isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
-- Arg mapping for standard (slow) entry point; all args on stack
(spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
- = mkVirtStkOffsets
+ = mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
- getIdKind
+ getIdPrimRep
all_args
- -- Arg mapping for the fast entry point; as many args as poss in
+ -- Arg mapping for the fast entry point; as many args as poss in
-- registers; the rest on the stack
-- arg_regs are the registers used for arg passing
-- stk_args are the args which are passed on the stack
stk_args = drop (length arg_regs) all_args
(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
- = mkVirtStkOffsets
+ = mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
- getIdKind
+ getIdPrimRep
stk_args
-- HWL; Note: empty list of live regs in slow entry code
-- Old version (reschedule combined with heap check);
-- see argSatisfactionCheck for new version
--slow_entry_code = forceHeapCheck [node] True slow_entry_code'
- -- where node = VanillaReg PtrKind 1
+ -- where node = VanillaReg PtrRep 1
--slow_entry_code = forceHeapCheck [] True slow_entry_code'
slow_entry_code
= profCtrC SLIT("ENT_FUN_STD") [] `thenC`
-
+
-- Bind args, and record expected position of stk ptrs
mapCs bindNewToAStack all_bxd_w_offsets `thenC`
mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
argSatisfactionCheck closure_info all_args `thenC`
- -- OK, so there are enough args. Now we need to stuff as
- -- many of them in registers as the fast-entry code expects
- -- Note that the zipWith will give up when it hits the end of arg_regs
+ -- OK, so there are enough args. Now we need to stuff as
+ -- many of them in registers as the fast-entry code
+ -- expects Note that the zipWith will give up when it hits
+ -- the end of arg_regs.
+
mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
else AbsCNop
) `thenC`
-
-#ifndef DPH
- absC (CFallThrough (CLbl fast_label CodePtrKind))
-#else
- -- Fall through to the fast entry point
- absC (AbsCNop)
-#endif {- Data Parallel Haskell -}
+ absC (CFallThrough (CLbl fast_label CodePtrRep))
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-- see argSatisfactionCheck for new version
-- fast_entry_code = forceHeapCheck [] True fast_entry_code'
- fast_entry_code
- = profCtrC SLIT("ENT_FUN_DIRECT") [
- CLbl (mkRednCountsLabel id) PtrKind,
+ fast_entry_code
+ = profCtrC SLIT("ENT_FUN_DIRECT") [
+ CLbl (mkRednCountsLabel id) PtrRep,
CString (_PK_ (showId PprDebug id)),
mkIntCLit stg_arity, -- total # of args
mkIntCLit spA_stk_args, -- # passed on A stk
mkIntCLit spB_stk_args, -- B stk (rest in regs)
- CString (_PK_ (map (showTypeCategory . getIdUniType) all_args)),
+ CString (_PK_ (map (showTypeCategory . idType) all_args)),
CString (_PK_ (show_wrapper_name wrapper_maybe)),
CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
] `thenC`
funWrapper closure_info arg_regs (cgExpr body)
in
-- Make a labelled code-block for the slow and fast entry code
- forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
+ forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
`thenFC` \ slow_abs_c ->
forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
moduleName `thenFC` \ mod_name ->
getIntSwitchChkrC `thenFC` \ isw_chkr ->
-
+
-- Now either construct the info table, or put the fast code in alone
-- (We never have slow code without an info table)
absC (
if info_table_needed then
- CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
+ CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
stdUpd (cl_descr mod_name)
(dataConLiveness isw_chkr closure_info)
- else
+ else
CCodeBlock fast_label fast_abs_c
)
where
-- Manufacture labels
id = closureId closure_info
-
+
fast_label = fastLabelFromCI closure_info
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind
+ stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
wrapper_maybe = get_ultimate_wrapper Nothing id
where
show_wrapper_arg_kinds Nothing = ""
show_wrapper_arg_kinds (Just xx)
- = case (getWrapperArgTypeCategories (getIdUniType xx) (getIdStrictness xx)) of
+ = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
Nothing -> ""
Just str -> str
\end{code}
-- NB: chk defn of "is_current_CC"
-- if you go to change this! (WDP 94/12)
costCentresC
- (case is_thunk of
+ (case is_thunk of
IsThunk -> SLIT("ENTER_CC_TCL")
IsFunction -> SLIT("ENTER_CC_FCL"))
[CReg node]
else -- we've got a "real" cost centre right here in our hands...
costCentresC
- (case is_thunk of
+ (case is_thunk of
IsThunk -> SLIT("ENTER_CC_T")
IsFunction -> SLIT("ENTER_CC_F"))
[mkCCostCentre cc]
where
is_current_CC cc
= currentOrSubsumedCosts cc
- -- but we've already ruled out "subsumed", so it must be "current"!
+ -- but we've already ruled out "subsumed", so it must be "current"!
\end{code}
%************************************************************************
argSatisfactionCheck closure_info args
= -- safest way to determine which stack last arg will be on:
-- look up CAddrMode that last arg is bound to;
- -- getAmodeKind;
- -- check isFollowableKind.
+ -- getAmodeRep;
+ -- check isFollowableRep.
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-- HWL:
-- absC (CMacroStmt GRAN_FETCH []) `thenC`
-- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
- (if node_points
+ (if node_points
then fetchAndReschedule [] node_points
else absC AbsCNop) `thenC`
#endif {- GRAN -}
getCAddrMode (last args) `thenFC` \ last_amode ->
- if (isFollowableKind (getAmodeKind last_amode)) then
- getSpARelOffset 0 `thenFC` \ a_rel_offset ->
+ if (isFollowableRep (getAmodeRep last_amode)) then
+ getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
if node_points then
- absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt a_rel_offset)])
+ absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt spA off)])
else
absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
- [mkIntCLit (spARelToInt a_rel_offset), set_Node_to_this])
+ [mkIntCLit (spARelToInt spA off), set_Node_to_this])
else
getSpBRelOffset 0 `thenFC` \ b_rel_offset ->
if node_points then
-- the closure or not. If it isn't so pointing, then we give to
-- the macro the (static) address of the closure.
- set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrKind
+ set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
\end{code}
%************************************************************************
#ifdef GRAN
-- HWL insert macros for GrAnSim if node is live here
- (if node_points
- then fetchAndReschedule [] node_points
+ (if node_points
+ then fetchAndReschedule [] node_points
else absC AbsCNop) `thenC`
#endif {- GRAN -}
-- Push update frame if necessary
setupUpdate closure_info ( -- setupUpdate *encloses* the rest
-
- -- Evaluation scoping -- load current cost centre from closure
- -- Must be done after the update frame is pushed
- -- Node is guaranteed to point to it, if profiling
--- OLD:
--- (if isStaticClosure closure_info
--- then evalCostCentreC "SET_CAFCC_CL" [CReg node]
--- else evalCostCentreC "ENTER_CC_TCL" [CReg node]) `thenC`
-
- -- Finally, do the business
- thunk_code
+ thunk_code
)))
funWrapper :: ClosureInfo -- Closure whose code body this is
Assumption: virtual and real stack pointers are currently exactly aligned.
\begin{code}
-stackCheck :: ClosureInfo
+stackCheck :: ClosureInfo
-> [MagicId] -- Live registers
-> Bool -- Node required to point after check?
- -> Code
+ -> Code
-> Code
stackCheck closure_info regs node_reqd code
= getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
-
+
getVirtSps `thenFC` \ (vSpA, vSpB) ->
let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
CMacroStmt STK_CHK [mkIntCLit liveness_mask,
mkIntCLit a_headroom_reqd,
mkIntCLit b_headroom_reqd,
- mkIntCLit vSpA,
+ mkIntCLit vSpA,
mkIntCLit vSpB,
mkIntCLit (if returns_prim_type then 1 else 0),
mkIntCLit (if node_reqd then 1 else 0)]
getIntSwitchChkrC `thenFC` \ isw_chkr ->
pushUpdateFrame update_closure (vector isw_chkr) code
else
- -- Non-updatable thunks still need a resume-cost-centre "update"
- -- frame to be pushed if we are doing evaluation profiling.
-
---OLD: evalPushRCCFrame False {-never primitive-} (
- profCtrC SLIT("UPDF_OMITTED") []
- `thenC`
+ profCtrC SLIT("UPDF_OMITTED") [] `thenC`
code
--- )
where
link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
link_caf_if_needed
-- Alloc black hole specifying CC_HDR(Node) as the cost centre
-- Hack Warning: Using a CLitLit to get CAddrMode !
let
- use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrKind
+ use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
blame_cc = use_cc
in
allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
`thenFC` \ heap_offset ->
- getHpRelOffset heap_offset `thenFC` \ hp_rel ->
+ getHpRelOffset heap_offset `thenFC` \ hp_rel ->
let amode = CAddr hp_rel
in
absC (CMacroStmt UPD_CAF [CReg node, amode])
Nothing -> CReg StdUpdRetVecReg
Just (spec_tycon, _, spec_datacons) ->
case (ctrlReturnConvAlg spec_tycon) of
- UnvectoredReturn 1 ->
+ UnvectoredReturn 1 ->
let
spec_data_con = head spec_datacons
- only_tag = getDataConTag spec_data_con
+ only_tag = getDataConTag spec_data_con
direct = case (dataReturnConvAlg isw_chkr spec_data_con) of
ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
CUnVecLbl direct vectored
UnvectoredReturn _ -> CReg StdUpdRetVecReg
- VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrKind
+ VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
\end{code}
%************************************************************************
closureDescription :: FAST_STRING -- Module
-> Id -- Id of closure binding
-> [Id] -- Args
- -> PlainStgExpr -- Body
+ -> StgExpr -- Body
-> String
-- Not called for StgRhsCon which have global info tables built in
closureDescription mod_name name args body =
uppShow 0 (prettyToUn (
- ppBesides [ppChar '<',
- ppPStr mod_name,
- ppChar '.',
- ppr PprDebug name,
- ppChar '>']))
+ ppBesides [ppChar '<',
+ ppPStr mod_name,
+ ppChar '.',
+ ppr PprDebug name,
+ ppChar '>']))
\end{code}
\begin{code}
blame_cc -- cost-centre on whom we blame the allocation
= case (args, fvs, body) of
- ([], [just1], StgApp (StgVarAtom fun) [{-no args-}] _)
- | just1 == fun
- -> mkCCostCentre overheadCostCentre
+ ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
+ | just1 == fun
+ -> mkCCostCentre overheadCostCentre
_ -> use_cc
-- if it's an utterly trivial RHS, then it must be
-- one introduced by boxHigherOrderArgs for profiling,
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgCompInfo where
-import AbsCSyn(RegRelative)
-import HeapOffs(HeapOffset)
-data RegRelative
-cON_UF_SIZE :: Int
-iND_TAG :: Integer
-lIVENESS_R1 :: Int
-lIVENESS_R2 :: Int
-lIVENESS_R3 :: Int
-lIVENESS_R4 :: Int
-lIVENESS_R5 :: Int
-lIVENESS_R6 :: Int
-lIVENESS_R7 :: Int
-lIVENESS_R8 :: Int
-mAX_Double_REG :: Int
-mAX_FAMILY_SIZE_FOR_VEC_RETURNS :: Int
-mAX_Float_REG :: Int
-mAX_INTLIKE :: Integer
-mAX_SPEC_ALL_NONPTRS :: Int
-mAX_SPEC_ALL_PTRS :: Int
-mAX_SPEC_MIXED_FIELDS :: Int
-mAX_SPEC_SELECTEE_SIZE :: Int
-mAX_Vanilla_REG :: Int
-mIN_BIG_TUPLE_SIZE :: Int
-mIN_INTLIKE :: Integer
-mIN_MP_INT_SIZE :: Int
-mIN_SIZE_NonUpdHeapObject :: Int
-mIN_SIZE_NonUpdStaticHeapObject :: Int
-mIN_UPD_SIZE :: Int
-mP_STRUCT_SIZE :: Int
-oTHER_TAG :: Integer
-sCC_CON_UF_SIZE :: Int
-sCC_STD_UF_SIZE :: Int
-sTD_UF_SIZE :: Int
-spARelToInt :: RegRelative -> Int
-spBRelToInt :: RegRelative -> Int
-uF_COST_CENTRE :: Int
-uF_RET :: Int
-uF_SUA :: Int
-uF_SUB :: Int
-uF_UPDATEE :: Int
-uNFOLDING_CHEAP_OP_COST :: Int
-uNFOLDING_CON_DISCOUNT_WEIGHT :: Int
-uNFOLDING_CREATION_THRESHOLD :: Int
-uNFOLDING_DEAR_OP_COST :: Int
-uNFOLDING_NOREP_LIT_COST :: Int
-uNFOLDING_OVERRIDE_THRESHOLD :: Int
-uNFOLDING_USE_THRESHOLD :: Int
-
uF_COST_CENTRE,
mAX_Vanilla_REG,
-#ifndef DPH
mAX_Float_REG,
mAX_Double_REG,
-#else
- mAX_Data_REG,
-#endif {- Data Parallel Haskell -}
mIN_BIG_TUPLE_SIZE,
mIN_MP_INT_SIZE,
- mP_STRUCT_SIZE,
+ mP_STRUCT_SIZE,
oTHER_TAG, iND_TAG, -- semi-tagging stuff
spARelToInt,
- spBRelToInt,
+ spBRelToInt
-- and to make the interface self-sufficient...
- RegRelative
+-- RegRelative
) where
-- This magical #include brings in all the everybody-knows-these magic
-- we want; if we just hope a -I... will get the right one, we could
-- be in trouble.
-#ifndef DPH
#include "../../includes/GhcConstants.h"
-#else
-#include "../dphsystem/imports/DphConstants.h"
-#endif {- Data Parallel Haskell -}
-import AbsCSyn
+CHK_Ubiq() -- debugging consistency check
+
import Util
\end{code}
\begin{code}
-- THESE ARE DIRECTION SENSITIVE!
-spARelToInt (SpARel spA off) = spA - off -- equiv to: AREL(spA - off)
-spBRelToInt (SpBRel spB off) = off - spB -- equiv to: BREL(spB - off)
+spARelToInt spA off = spA - off -- equiv to: AREL(spA - off)
+spBRelToInt spB off = off - spB -- equiv to: BREL(spB - off)
\end{code}
A section of code-generator-related MAGIC CONSTANTS.
\end{code}
\begin{code}
-#ifndef DPH
mAX_Vanilla_REG = (MAX_VANILLA_REG :: Int)
mAX_Float_REG = (MAX_FLOAT_REG :: Int)
mAX_Double_REG = (MAX_DOUBLE_REG :: Int)
-#else
--- The DAP has only got 14 registers :-( After various heap and stack
--- pointers we dont have that many left over..
-mAX_Vanilla_REG = (4 :: Int) -- Ptr, Int, Char, Float
-mAX_Data_REG = (4 :: Int) -- Int, Char, Float, Double
-mAX_Float_REG = error "mAX_Float_REG : not used in DPH"
-mAX_Double_REG = error "mAX_Double_REG: not used in DPH"
-#endif {- Data Parallel Haskell -}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgCon where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, MagicId, RegRelative)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CAddrMode
-data MagicId
-data CgState
-data Id
-data PrimKind
-data PrimOp
-data StgAtom a
-bindConArgs :: Id -> [Id] -> CgInfoDownwards -> CgState -> CgState
-buildDynCon :: Id -> CostCentre -> Id -> [CAddrMode] -> Bool -> CgInfoDownwards -> CgState -> (CgIdInfo, CgState)
-cgReturnDataCon :: Id -> [CAddrMode] -> Bool -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState
-cgTopRhsCon :: Id -> Id -> [StgAtom Id] -> Bool -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
-
-- it's all exported, actually...
cgTopRhsCon, buildDynCon,
bindConArgs,
- cgReturnDataCon,
+ cgReturnDataCon
-- and to make the interface self-sufficient...
- Id, StgAtom, CgState, CAddrMode,
- PrimKind, PrimOp, MagicId
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty
-
import StgSyn
import CgMonad
import AbsCSyn
-import AbsUniType ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
- TyCon, Class, UniType
+import Type ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
+ TyCon, Class, Type
)
import CgBindery ( getAtomAmode, getAtomAmodes, bindNewToNode,
bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode
)
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import CgUsages ( getHpRelOffset )
-import CLabelInfo ( CLabel, mkClosureLabel, mkInfoTableLabel,
- mkPhantomInfoTableLabel,
+import CLabel ( CLabel, mkClosureLabel, mkInfoTableLabel,
+ mkPhantomInfoTableLabel,
mkConEntryLabel, mkStdEntryLabel
)
import ClosureInfo -- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas
layOutStaticClosure, UpdateFlag(..),
mkClosureLFInfo, layOutStaticNoFVClosure
)-}
-import Id ( getIdKind, getDataConTag, getDataConTyCon,
+import Id ( getIdPrimRep, getDataConTag, getDataConTyCon,
isDataCon, fIRST_TAG, DataCon(..), ConTag(..)
)
-import CmdLineOpts ( GlobalSwitch(..) )
import Maybes ( maybeToBool, Maybe(..) )
-import PrimKind ( PrimKind(..), isFloatingKind, getKindSize )
+import PrimRep ( PrimRep(..), isFloatingRep, getPrimRepSize )
import CostCentre
import UniqSet -- ( emptyUniqSet, UniqSet(..) )
import Util
\begin{code}
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
- -> [PlainStgAtom] -- Args
+ -> [StgArg] -- Args
-> Bool -- All zero-size args (see buildDynCon)
-> FCode (Id, CgIdInfo)
\end{code}
-Special Case:
+Special Case:
Constructors some of whose arguments are of \tr{Float#} or
\tr{Double#} type, {\em or} which are ``lit lits'' (which are given
\tr{Addr#} type).
STATIC_INFO_TABLE(Main_x,Main_x_entry,,,,EXTFUN,???,":MkDouble","Double");
-- with its *own* entry code:
STGFUN(Main_x_entry) {
- P_ u1701;
+ P_ u1701;
RetDouble1=2.0;
u1701=(P_)*SpB;
SpB=SpB-1;
top_ccc = mkCCostCentre dontCareCostCentre -- because it's static data
cgTopRhsCon name con args all_zero_size_args
- | any (isFloatingKind . getAtomKind) args
- || any isLitLitStgAtom args
+ | any (isFloatingRep . getArgPrimRep) args
+ || any isLitLitArg args
= cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
where
- body = StgConApp con args emptyUniqSet{-emptyLiveVarSet-}
+ body = StgCon con args emptyUniqSet{-emptyLiveVarSet-}
lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
\end{code}
let
(closure_info, amodes_w_offsets)
- = layOutStaticClosure name getAmodeKind amodes lf_info
+ = layOutStaticClosure name getAmodeRep amodes lf_info
in
-- HWL: In 0.22 there was a heap check in here that had to be changed.
-- CHECK if having no heap check is ok for GrAnSim here!!!
) `thenC`
-- RETURN
- returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info)
+ returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
where
con_tycon = getDataConTyCon con
lf_info = mkConLFInfo con
will not have set it. Therefore, the whole point of \tr{x_entry} is
to set node (and then call the shared \tr{MkFoo} entry code).
-
-
Special Case:
For top-level Int/Char constants. We get entry-code fragments of the form:
}
\end{verbatim}
-This blob used to be in cgTopRhsCon, but I don't see how we can
-jump direct to the named code for a constructor; any external entries
-will be via Node. Generating all this extra code is a real waste
-for big static data structures. So I've nuked it. SLPJ Sept 94
-
-
-Further discourse on these entry-code fragments (NB this isn't done
-yet [ToDo]): They're really pretty pointless, except for {\em
-exported} top-level constants (the rare case). Consider:
-\begin{verbatim}
-y = p : ps -- y is not exported
-f a b = y
-g c = (y, c)
-\end{verbatim}
-Why have a \tr{y_entry} fragment at all? The code generator should
-``know enough'' about \tr{y} not to need it. For the first case
-above, with \tr{y} in ``head position,'' it should generate code just
-as for an \tr{StgRhsCon} (possibly because the STG simplification
-actually did the unfolding to make it so). At the least, it should
-load up \tr{Node} and call \tr{Cons}'s entry code---not some special
-\tr{y_entry} code.
-
-\begin{pseudocode}
- -- WE NEED AN ENTRY PT, IN CASE SOMEONE JUMPS DIRECT TO name
- -- FROM OUTSIDE. NB: this CCodeBlock precedes the
- -- CStaticClosure for the same reason (fewer forward refs) as
- -- we did in CgClosure.
-
- -- we either have ``in-line'' returning code (special case)
- -- or we set Node and jump to the constructor's entry code
-
- (if maybeToBool (maybeCharLikeTyCon con_tycon)
- || maybeToBool (maybeIntLikeTyCon con_tycon)
- then -- special case
- getAbsC (-- OLD: No, we don't fiddle cost-centres on
- -- entry to data values any more (WDP 94/06)
- -- lexCostCentreC "ENTER_CC_D" [top_ccc]
- -- `thenC`
- cgReturnDataCon con amodes all_zero_size_args emptyUniqSet{-no live vars-})
- else -- boring case
- returnFC (
- mkAbstractCs [
- -- Node := this_closure
- CAssign (CReg node) (CLbl closure_label PtrKind),
- -- InfoPtr := info table for this_closure
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind),
- -- Jump to std code for this constructor
- CJump (CLbl con_entry_label CodePtrKind)
- ])
- ) `thenFC` \ ret_absC ->
-
- absC (CCodeBlock entry_label ret_absC) `thenC`
-\end{pseudocode}
-
-=========================== END OF OLD STUFF ==============================
-
+This blob used to be in cgTopRhsCon, but I don't see how we can jump
+direct to the named code for a constructor; any external entries will
+be via Node. Generating all this extra code is a real waste for big
+static data structures. So I've nuked it. SLPJ Sept 94
%************************************************************************
%* *
-> DataCon -- The data constructor
-> [CAddrMode] -- Its args
-> Bool -- True <=> all args (if any) are
- -- of "zero size" (i.e., VoidKind);
+ -- of "zero size" (i.e., VoidRep);
-- The reason we don't just look at the
-- args is that we may be in a "knot", and
-- premature looking at the args will cause
\end{code}
First we deal with the case of zero-arity constructors. Now, they
-will probably be unfolded, so we don't expect to see this case
-much, if at all, but it does no harm, and sets the scene for characters.
+will probably be unfolded, so we don't expect to see this case much,
+if at all, but it does no harm, and sets the scene for characters.
-In the case of zero-arity constructors, or, more accurately,
-those which have exclusively size-zero (VoidKind) args,
-we generate no code at all.
+In the case of zero-arity constructors, or, more accurately, those
+which have exclusively size-zero (VoidRep) args, we generate no code
+at all.
\begin{code}
buildDynCon binder cc con args all_zero_size_args@True
= ASSERT(isDataCon con)
returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel con) PtrKind)
+ (CLbl (mkClosureLabel con) PtrRep)
(mkConLFInfo con))
\end{code}
Now for @Char@-like closures. We generate an assignment of the
address of the closure to a temporary. It would be possible simply to
-generate no code, and record the addressing mode in the environment, but
-we'd have to be careful if the argument wasn't a constant --- so for simplicity
-we just always asssign to a temporary.
+generate no code, and record the addressing mode in the environment,
+but we'd have to be careful if the argument wasn't a constant --- so
+for simplicity we just always asssign to a temporary.
-Last special case: @Int@-like closures. We only special-case the situation
-in which the argument is a literal in the range @mIN_INTLIKE@..@mAX_INTLILKE@.
-NB: for @Char@-like closures we can work with any old argument, but
-for @Int@-like ones the argument has to be a literal. Reason: @Char@ like
-closures have an argument type which is guaranteed in range.
+Last special case: @Int@-like closures. We only special-case the
+situation in which the argument is a literal in the range
+@mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can
+work with any old argument, but for @Int@-like ones the argument has
+to be a literal. Reason: @Char@ like closures have an argument type
+which is guaranteed in range.
Because of this, we use can safely return an addressing mode.
(temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
in_range_int_lit (CLit (MachInt val _)) = (val <= mAX_INTLIKE) && (val >= mIN_INTLIKE)
- in_range_int_lit other_amode = False
+ in_range_int_lit other_amode = False
\end{code}
Now the general case.
returnFC (heapIdInfo binder hp_off (mkConLFInfo con))
where
(closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeKind args (mkConLFInfo con)
+ = layOutDynClosure binder getAmodeRep args (mkConLFInfo con)
use_cc -- cost-centre to stick in the object
= if currentOrSubsumedCosts cc
ReturnInRegs rs -> bindArgsToRegs args rs
ReturnInHeap ->
let
- (_, args_w_offsets) = layOutDynCon con getIdKind args
+ (_, args_w_offsets) = layOutDynCon con getIdPrimRep args
in
mapCs bind_arg args_w_offsets
where
Note: it's the responsibility of the @cgReturnDataCon@ caller to be
sure the @amodes@ passed don't conflict with each other.
\begin{code}
-cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> PlainStgLiveVars -> Code
+cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> StgLiveVars -> Code
cgReturnDataCon con amodes all_zero_size_args live_vars
= ASSERT(isDataCon con)
CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl))))
| not (getDataConTag con `is_elem` map fst alts)
- ->
+ ->
-- Special case! We're returning a constructor to the default case
-- of an enclosing case. For example:
--
-- D x -> ...
-- y -> ...<returning here!>...
--
- -- In this case,
+ -- In this case,
-- if the default is a non-bind-default (ie does not use y),
-- then we should simply jump to the default join point;
--
-- **regardless** of the return convention of the constructor C.
case maybe_deflt_binder of
- Just binder ->
+ Just binder ->
buildDynCon binder useCurrentCostCentre con amodes all_zero_size_args
`thenFC` \ idinfo ->
- idInfoToAmode PtrKind idinfo `thenFC` \ amode ->
+ idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
performReturn (move_to_reg amode node) jump_to_join_point live_vars
Nothing ->
performReturn AbsCNop {- No reg assts -} jump_to_join_point live_vars
where
is_elem = isIn "cgReturnDataCon"
- jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrKind))
+ jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
-- Ignore the sequel: we've already looked at it above
other_sequel -> -- The usual case
-- affects profiling (ToDo?)
buildDynCon con useCurrentCostCentre con amodes all_zero_size_args
`thenFC` \ idinfo ->
- idInfoToAmode PtrKind idinfo `thenFC` \ amode ->
-
+ idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
+
-- MAKE NODE POINT TO IT
let reg_assts = move_to_reg amode node
info_lbl = mkInfoTableLabel con
ReturnInRegs regs ->
let
- reg_assts = mkAbstractCs (zipWith move_to_reg amodes regs)
+ reg_assts = mkAbstractCs (zipWithEqual move_to_reg amodes regs)
info_lbl = mkPhantomInfoTableLabel con
- in
+ in
profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`
performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgConTbls where
-import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgMonad(CompilationInfo)
-import ClosureInfo(ClosureInfo)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import FiniteMap(FiniteMap)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import TCE(TCE(..))
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data AbstractC
-data CompilationInfo
-type TCE = UniqFM TyCon
-data UniqFM a
-genStaticConBits :: CompilationInfo -> [TyCon] -> FiniteMap TyCon [(Bool, [Labda UniType])] -> AbstractC
-
import AbsCSyn
import CgMonad
-import AbsUniType ( getTyConDataCons, kindFromType,
+import Type ( getTyConDataCons, primRepFromType,
maybeIntLikeTyCon, mkSpecTyCon,
TyVarTemplate, TyCon, Class,
- TauType(..), UniType, ThetaType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+ TauType(..), Type, ThetaType(..)
)
import CgHeapery ( heapCheck, allocDynClosure )
import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
)
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import CgUsages ( getHpRelOffset )
-import CLabelInfo ( mkConEntryLabel, mkStaticConEntryLabel,
- --UNUSED: mkInfoTableLabel,
- mkClosureLabel, --UNUSED: mkConUpdCodePtrUnvecLabel,
- mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
+import CLabel ( mkConEntryLabel, mkStaticConEntryLabel,
+ mkClosureLabel,
+ mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
mkStdUpdVecTblLabel, CLabel
)
import ClosureInfo ( layOutStaticClosure, layOutDynCon,
fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure,
infoTableLabelFromCI, dataConLiveness
)
-import CmdLineOpts ( GlobalSwitch(..) )
import FiniteMap
import Id ( getDataConTag, getDataConSig, getDataConTyCon,
mkSameSpecCon,
)
import CgCompInfo ( uF_UPDATEE )
import Maybes ( maybeToBool, Maybe(..) )
-import PrimKind ( getKindSize, retKindSize )
+import PrimRep ( getPrimRepSize, retPrimRepSize )
import CostCentre
import UniqSet -- ( emptyUniqSet, UniqSet(..) )
-import TCE ( rngTCE, TCE(..), UniqFM )
import Util
\end{code}
For every constructor we generate the following info tables:
- A static info table, for static instances of the constructor,
+ A static info table, for static instances of the constructor,
- For constructors which return in registers (and only them),
+ For constructors which return in registers (and only them),
an "inregs" info table. This info table is rather emaciated;
it only contains update code and tag.
the closure tries to get rid of itself.
\item[@con_inregs_info@:]
-Used when returning a new constructor in registers.
+Used when returning a new constructor in registers.
Only for return-in-regs constructors.
Macro: @INREGS_INFO_TABLE@.
\begin{code}
genStaticConBits :: CompilationInfo -- global info about the compilation
-> [TyCon] -- tycons to generate
- -> FiniteMap TyCon [(Bool, [Maybe UniType])]
+ -> FiniteMap TyCon [(Bool, [Maybe Type])]
-- tycon specialisation info
-> AbstractC -- output
mkAbstractCs [ gen_for_tycon tc | tc <- gen_tycons ]
`mkAbsCStmts`
- mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec
- | (imported_spec, spec) <- specs,
- -- no code generated if spec is imported
- not imported_spec
- ]
- | (tc, specs) <- fmToList tycon_specs ]
+ mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec
+ | (imported_spec, spec) <- specs,
+ -- no code generated if spec is imported
+ not imported_spec
+ ]
+ | (tc, specs) <- fmToList tycon_specs ]
where
gen_for_tycon :: TyCon -> AbstractC
gen_for_tycon tycon
VectoredReturn _ -> CFlatRetVector tycon_upd_label
(map (mk_upd_label tycon) data_cons)
------------------
- gen_for_spec_tycon :: TyCon -> [Maybe UniType] -> AbstractC
+ gen_for_spec_tycon :: TyCon -> [Maybe Type] -> AbstractC
gen_for_spec_tycon tycon ty_maybes
= mkAbstractCs (map (genConInfo comp_info spec_tycon) spec_data_cons)
`mkAbsCStmts`
- maybe_spec_tycon_vtbl
+ maybe_spec_tycon_vtbl
where
data_cons = getTyConDataCons tycon
------------------
mk_upd_label tycon con
= CLbl
- (case (dataReturnConvAlg isw_chkr con) of
+ (case (dataReturnConvAlg isw_chkr con) of
ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag)
- CodePtrKind
+ CodePtrRep
where
tag = getDataConTag con
-- To allow the debuggers, interpreters, etc to cope with static
-- data structures (ie those built at compile time), we take care that
-- info-table contains the information we need.
- (static_ci,_) = layOutStaticClosure data_con kindFromType arg_tys (mkConLFInfo data_con)
+ (static_ci,_) = layOutStaticClosure data_con primRepFromType arg_tys (mkConLFInfo data_con)
body = (initC comp_info (
profCtrC SLIT("ENT_CON") [CReg node] `thenC`
body_code))
- entry_addr = CLbl entry_label CodePtrKind
+ entry_addr = CLbl entry_label CodePtrRep
con_descr = _UNPK_ (getOccurrenceName data_con)
closure_code = CClosureInfoAndCode closure_info body Nothing
inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con
- stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind
+ stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep
tag = getDataConTag data_con
cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
-- For zero-arity data constructors, or, more accurately,
- -- those which only have VoidKind args (or none):
+ -- those which only have VoidRep args (or none):
-- We make the closure too (not just info tbl), so that we can share
-- one copy throughout.
- closure_maybe = -- OLD: if con_arity /= 0 then
- if not (all zero_size arg_tys) then
+ closure_maybe = if not (all zero_size arg_tys) then
AbsCNop
- else
+ else
CStaticClosure closure_label -- Label for closure
static_ci -- Info table
cost_centre
- [{-No args! A slight lie for constrs with VoidKind args-}]
+ [{-No args! A slight lie for constrs with VoidRep args-}]
- zero_size arg_ty = getKindSize (kindFromType arg_ty) == 0
+ zero_size arg_ty = getPrimRepSize (primRepFromType arg_ty) == 0
(_,_,arg_tys,_) = getDataConSig data_con
con_arity = getDataConArity data_con
performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
+ emptyUniqSet{-no live vars-}
in
(closure_info, body_code)
-
+
ReturnInHeap ->
let
(_, _, arg_tys, _) = getDataConSig con
(closure_info, arg_things)
- = layOutDynCon con kindFromType arg_tys
+ = layOutDynCon con primRepFromType arg_tys
body_code
- = -- OLD: We don't set CC when entering data any more (WDP 94/06)
- -- lexCostCentreC "ENTER_CC_DCL" [CReg node] `thenC`
+ = -- NB: We don't set CC when entering data (WDP 94/06)
profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
performReturn AbsCNop -- Ptr to thing already in Node
- (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
+ (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
+ emptyUniqSet{-no live vars-}
in
(closure_info, body_code)
move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
move_to_reg (reg, offset)
= CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
-\end{code}
+\end{code}
%************************************************************************
%* *
genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
-genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
+genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
= case (dataReturnConvAlg isw_chkr data_con) of
- ReturnInHeap -> --OLD: pprTrace "NoPhantom: " (ppr PprDebug data_con) $
- AbsCNop -- No need for a phantom update
+ ReturnInHeap -> AbsCNop -- No need for a phantom update
- ReturnInRegs regs ->
- --OLD: pprTrace "YesPhantom! " (ppr PprDebug data_con) $
- let
- phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
+ ReturnInRegs regs ->
+ let
+ phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
upd_code con_descr
(dataConLiveness isw_chkr phantom_ci)
- phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
-
- con_descr = _UNPK_ (getOccurrenceName data_con)
+ phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
+
+ con_descr = _UNPK_ (getOccurrenceName data_con)
- con_arity = getDataConArity data_con
+ con_arity = getDataConArity data_con
- upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
+ upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
upd_label = mkConUpdCodePtrVecLabel tycon tag
- tag = getDataConTag data_con
+ tag = getDataConTag data_con
- updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrKind
+ updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrRep
- perform_return = mkAbstractCs
- [
- CMacroStmt POP_STD_UPD_FRAME [],
- CReturn (CReg RetReg) return_info
- ]
+ perform_return = mkAbstractCs
+ [
+ CMacroStmt POP_STD_UPD_FRAME [],
+ CReturn (CReg RetReg) return_info
+ ]
- return_info =
- -- OLD: pprTrace "ctrlReturn6:" (ppr PprDebug tycon) (
+ return_info =
case (ctrlReturnConvAlg tycon) of
UnvectoredReturn _ -> DirectReturn
- VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG)
- -- )
+ VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG)
-- Determine cost centre for the updated closures CC (and allocation)
-- CCC for lexical (now your only choice)
use_cc = CReg CurCostCentre -- what to put in the closure
blame_cc = use_cc -- who to blame for allocation
- do_move (reg, virt_offset) =
+ do_move (reg, virt_offset) =
CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg)
overwrite_code
= profCtrC SLIT("UPD_CON_IN_PLACE")
[mkIntCLit (length regs_w_offsets)] `thenC`
- absC (mkAbstractCs
- [
+ absC (mkAbstractCs
+ [
CAssign (CReg node) updatee,
-- Tell the storage mgr that we intend to update in place
CInitHdr closure_info (NodeRel zeroOff) use_cc True,
mkAbstractCs (map do_move regs_w_offsets),
if con_arity /= 0 then
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
- else
+ CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
+ else
AbsCNop
])
- upd_inplace_macro = if closurePtrsSize closure_info == 0
+ upd_inplace_macro = if closurePtrsSize closure_info == 0
then UPD_INPLACE_NOPTRS
else UPD_INPLACE_PTRS
-- Allocate and build closure specifying upd_new_w_regs
allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
`thenFC` \ hp_offset ->
- getHpRelOffset hp_offset `thenFC` \ hp_rel ->
+ getHpRelOffset hp_offset `thenFC` \ hp_rel ->
let
amode = CAddr hp_rel
in
profCtrC SLIT("UPD_CON_IN_NEW")
[mkIntCLit (length amodes_w_offsets)] `thenC`
- absC (mkAbstractCs
+ absC (mkAbstractCs
[ CMacroStmt UPD_IND [updatee, amode],
CAssign (CReg node) amode,
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
+ CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
])
- (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
- info_label = infoTableLabelFromCI closure_info
- liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
+ (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
+ info_label = infoTableLabelFromCI closure_info
+ liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
- build_closure =
+ build_closure =
if fitsMinUpdSize closure_info then
- initC comp_info overwrite_code
+ initC comp_info overwrite_code
else
- initC comp_info (heapCheck regs False alloc_code)
+ initC comp_info (heapCheck regs False alloc_code)
- in CClosureUpdInfo phantom_itbl
+ in CClosureUpdInfo phantom_itbl
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgExpr where
-import AbsCSyn(AbstractC, CAddrMode)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import PrimOps(PrimOp)
-import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgExpr)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CgState
-data Id
-data StgExpr a b
-cgExpr :: StgExpr Id Id -> CgInfoDownwards -> CgState -> CgState
-cgSccExpr :: StgExpr Id Id -> CgInfoDownwards -> CgState -> CgState
-getPrimOpArgAmodes :: PrimOp -> [StgAtom Id] -> CgInfoDownwards -> CgState -> ([CAddrMode], CgState)
-
#include "HsVersions.h"
module CgExpr (
- cgExpr, cgSccExpr, getPrimOpArgAmodes,
+ cgExpr, cgSccExpr, getPrimOpArgAmodes
-- and to make the interface self-sufficient...
- StgExpr, Id, CgState
) where
-IMPORT_Trace -- NB: not just for debugging
-import Outputable -- ToDo: rm (just for debugging)
-import Pretty -- ToDo: rm (just for debugging)
-
import StgSyn
import CgMonad
import AbsCSyn
-import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..),
- primOpHeapReq, getPrimOpResultInfo, PrimKind,
+import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..),
+ primOpHeapReq, getPrimOpResultInfo, PrimRep,
primOpCanTriggerGC
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( isPrimType, getTyConDataCons )
-import CLabelInfo ( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
+import Type ( isPrimType, getTyConDataCons )
+import CLabel ( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo )
import CgBindery ( getAtomAmodes )
import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgLetNoEscape ( cgLetNoEscapeClosure )
import CgRetConv -- various things...
import CgTailCall ( cgTailCall, performReturn, mkDynamicAlgReturnCode,
- mkPrimReturnCode
- )
+ mkPrimReturnCode
+ )
import CostCentre ( setToAbleCostCentre, isDupdCC, CostCentre )
import Maybes ( Maybe(..) )
-import PrimKind ( getKindSize )
+import PrimRep ( getPrimRepSize )
import UniqSet
import Util
\end{code}
with closures, and @CgCon@, which deals with constructors.
\begin{code}
-cgExpr :: PlainStgExpr -- input
+cgExpr :: StgExpr -- input
-> Code -- output
\end{code}
``Applications'' mean {\em tail calls}, a service provided by module
@CgTailCall@. This includes literals, which show up as
-@(STGApp (StgLitAtom 42) [])@.
+@(STGApp (StgLitArg 42) [])@.
\begin{code}
cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
%********************************************************
\begin{code}
-cgExpr (StgConApp con args live_vars)
+cgExpr (StgCon con args live_vars)
= getAtomAmodes args `thenFC` \ amodes ->
cgReturnDataCon con amodes (all zero_size args) live_vars
where
- zero_size atom = getKindSize (getAtomKind atom) == 0
+ zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
\end{code}
%********************************************************
Here is where we insert real live machine instructions.
\begin{code}
-cgExpr x@(StgPrimApp op args live_vars)
+cgExpr x@(StgPrim op args live_vars)
= getIntSwitchChkrC `thenFC` \ isw_chkr ->
getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
let
-- Use registers for args, and assign args to the regs
-- (Can-trigger-gc primops guarantee to have their args in regs)
let
- (arg_robust_amodes, liveness_mask, arg_assts)
+ (arg_robust_amodes, liveness_mask, arg_assts)
= makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
liveness_arg = mkIntCLit liveness_mask
ReturnsPrim kind ->
performReturn do_before_stack_cleanup
- (\ sequel -> robustifySequel may_gc sequel
+ (\ sequel -> robustifySequel may_gc sequel
`thenFC` \ (ret_asst, sequel') ->
absC (ret_asst `mkAbsCStmts` do_just_before_jump)
`thenC`
live_vars
ReturnsAlg tycon ->
---OLD: evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC`
profCtrC SLIT("RET_NEW_IN_REGS") [num_of_fields] `thenC`
performReturn do_before_stack_cleanup
(\ sequel -> robustifySequel may_gc sequel
`thenFC` \ (ret_asst, sequel') ->
- absC (mkAbstractCs [ret_asst,
- do_just_before_jump,
+ absC (mkAbstractCs [ret_asst,
+ do_just_before_jump,
info_ptr_assign])
-- Must load info ptr here, not in do_just_before_stack_cleanup,
-- because the info-ptr reg clashes with argument registers
info_ptr_assign = CAssign (CReg infoptr) info_lbl
info_lbl
- = -- OLD: pprTrace "ctrlReturn7:" (ppr PprDebug tycon) (
- case (ctrlReturnConvAlg tycon) of
- VectoredReturn _ -> vec_lbl
+ = case (ctrlReturnConvAlg tycon) of
+ VectoredReturn _ -> vec_lbl
UnvectoredReturn _ -> dir_lbl
- -- )
- vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrKind)
- dyn_tag DataPtrKind
+ vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep)
+ dyn_tag DataPtrRep
data_con = head (getTyConDataCons tycon)
(dir_lbl, num_of_fields)
= case (dataReturnConvAlg fake_isw_chkr data_con) of
ReturnInRegs rs
- -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrKind,
---OLD: pprTrace "CgExpr:prim datacon:" (ppr PprDebug data_con) $
+ -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep,
mkIntCLit (length rs)) -- for ticky-ticky only
ReturnInHeap
-- sequel is OnStack. If that's the case, arrange to pull the
-- sequel out into RetReg before performing the primOp.
- robustifySequel True sequel@(OnStack _) =
+ robustifySequel True sequel@(OnStack _) =
sequelToAmode sequel `thenFC` \ amode ->
returnFC (CAssign (CReg RetReg) amode, InRetReg)
robustifySequel _ sequel = returnFC (AbsCNop, sequel)
cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
= -- Figure out what volatile variables to save
nukeDeadBindings live_in_whole_let `thenC`
- saveVolatileVarsAndRegs live_in_rhss
+ saveVolatileVarsAndRegs live_in_rhss
`thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) ->
-- ToDo: cost centre???
- -- Save those variables right now!
+ -- Save those variables right now!
absC save_assts `thenC`
-- Produce code for the rhss
nested SCCs.
\begin{code}
-cgExpr scc_expr@(StgSCC ty cc expr)
---OLD:WDP:94/06 = evalPushRCCFrame (isPrimType ty) (cgSccExpr scc_expr)
- = cgSccExpr scc_expr
+cgExpr scc_expr@(StgSCC ty cc expr) = cgSccExpr scc_expr
\end{code}
@cgSccExpr@ (also used in \tr{CgClosure}):
\subsection[non-top-level-bindings]{Converting non-top-level bindings}
@cgBinding@ is only used for let/letrec, not for unboxed bindings.
-So the kind should always be @PtrKind@.
+So the kind should always be @PtrRep@.
We rely on the support code in @CgCon@ (to do constructors) and
in @CgClosure@ (to do closures).
\begin{code}
-cgRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along so a binding can be set up
cgRhs name (StgRhsCon maybe_cc con args)
`thenFC` \ idinfo ->
returnFC (name, idinfo)
where
- zero_size atom = getKindSize (getAtomKind atom) == 0
+ zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
= cgRhsClosure name cc bi fvs args body lf_info
\begin{code}
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
- = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
+ = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
= fixC (\ new_bindings ->
addBindsC new_bindings `thenC`
- listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
- maybe_cc_slot b e | (b,e) <- pairs ]
+ listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info
+ maybe_cc_slot b e | (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
addBindsC new_bindings
-- delete the bindings for the binder from the environment!
full_live_in_rhss = live_in_rhss `unionUniqSets` (mkUniqSet [b | (b,r) <- pairs])
-cgLetNoEscapeRhs
- :: PlainStgLiveVars -- Live in rhss
- -> EndOfBlockInfo
+cgLetNoEscapeRhs
+ :: StgLiveVars -- Live in rhss
+ -> EndOfBlockInfo
-> Maybe VirtualSpBOffset
-> Id
- -> PlainStgRhs
+ -> StgRhs
-> FCode (Id, CgIdInfo)
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
-- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
--- For a constructor RHS we want to generate a single chunk of code which
+-- For a constructor RHS we want to generate a single chunk of code which
-- can be jumped to from many places, which will return the constructor.
-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder
(StgRhsCon cc con args)
= cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot
[] --No args; the binder is data structure, not a function
- (StgConApp con args full_live_in_rhss)
+ (StgCon con args full_live_in_rhss)
\end{code}
Some PrimOps require a {\em fixed} amount of heap allocation. Rather
FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
returnFC (amode : arg_amodes)
- _ -> returnFC arg_amodes
+ _ -> returnFC arg_amodes
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgHeapery where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data AbstractC
-data CAddrMode
-data CgState
-data ClosureInfo
-data HeapOffset
-data Id
-allocDynClosure :: ClosureInfo -> CAddrMode -> CAddrMode -> [(CAddrMode, HeapOffset)] -> CgInfoDownwards -> CgState -> (HeapOffset, CgState)
-allocHeap :: HeapOffset -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-heapCheck :: [MagicId] -> Bool -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-
allocHeap, allocDynClosure,
#ifdef GRAN
- -- new for GrAnSim HWL
+ -- new for GrAnSim HWL
heapCheckOnly, fetchAndReschedule,
#endif {- GRAN -}
#ifndef GRAN
heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
+ -> Bool -- Node reqd after GC?
+ -> Code
-> Code
heapCheck regs node_reqd code
#ifdef GRAN
heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+ -> Bool -- Node reqd after GC?
+ -> Code
+ -> Code
heapCheck = heapCheck' False
heapCheckOnly :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+ -> Bool -- Node reqd after GC?
+ -> Code
+ -> Code
heapCheckOnly = heapCheck' False
--- May be emit context switch and emit heap check macro
+-- May be emit context switch and emit heap check macro
heapCheck' :: Bool -- context switch here?
- -> [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
+ -> [MagicId] -- Live registers
+ -> Bool -- Node reqd after GC?
+ -> Code
+ -> Code
heapCheck' do_context_switch regs node_reqd code
= initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
do_heap_chk :: HeapOffset -> Code
do_heap_chk words_required
- =
- -- HWL:: absC (CComment "Forced heap check --- HWL") `thenC`
- --absC (if do_context_switch
- -- then context_switch_code
- -- else AbsCNop) `thenC`
-
- absC (if do_context_switch && not (isZeroOff words_required)
- then context_switch_code
- else AbsCNop) `thenC`
- absC (if isZeroOff(words_required)
- then AbsCNop
- else checking_code) `thenC`
-
- -- HWL was here:
- -- For GrAnSim we want heap checks even if no heap is allocated in
- -- the basic block to make context switches possible.
- -- So, the if construct has been replaced by its else branch.
-
- -- The test is *inside* the absC, to avoid black holes!
-
- -- Now we have set up the real heap pointer and checked there is
- -- enough space. It remains only to reflect this in the environment
-
- setRealHp words_required
-
- -- The "word_required" here is a fudge.
- -- *** IT DEPENDS ON THE DIRECTION ***, and on
- -- whether the Hp is moved the whole way all
- -- at once or not.
+ =
+ -- HWL:: absC (CComment "Forced heap check --- HWL") `thenC`
+ --absC (if do_context_switch
+ -- then context_switch_code
+ -- else AbsCNop) `thenC`
+
+ absC (if do_context_switch && not (isZeroOff words_required)
+ then context_switch_code
+ else AbsCNop) `thenC`
+ absC (if isZeroOff(words_required)
+ then AbsCNop
+ else checking_code) `thenC`
+
+ -- HWL was here:
+ -- For GrAnSim we want heap checks even if no heap is allocated in
+ -- the basic block to make context switches possible.
+ -- So, the if construct has been replaced by its else branch.
+
+ -- The test is *inside* the absC, to avoid black holes!
+
+ -- Now we have set up the real heap pointer and checked there is
+ -- enough space. It remains only to reflect this in the environment
+
+ setRealHp words_required
+
+ -- The "word_required" here is a fudge.
+ -- *** IT DEPENDS ON THE DIRECTION ***, and on
+ -- whether the Hp is moved the whole way all
+ -- at once or not.
where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ all_regs = if node_reqd then node:regs else regs
+ liveness_mask = mkLiveRegsBitMask all_regs
- maybe_context_switch = if do_context_switch
- then context_switch_code
- else AbsCNop
+ maybe_context_switch = if do_context_switch
+ then context_switch_code
+ else AbsCNop
- context_switch_code = CMacroStmt THREAD_CONTEXT_SWITCH [
- mkIntCLit liveness_mask,
- mkIntCLit (if node_reqd then 1 else 0)]
+ context_switch_code = CMacroStmt THREAD_CONTEXT_SWITCH [
+ mkIntCLit liveness_mask,
+ mkIntCLit (if node_reqd then 1 else 0)]
- -- Good old heap check (excluding context switch)
- checking_code = CMacroStmt HEAP_CHK [
- mkIntCLit liveness_mask,
- COffset words_required,
- mkIntCLit (if node_reqd then 1 else 0)]
+ -- Good old heap check (excluding context switch)
+ checking_code = CMacroStmt HEAP_CHK [
+ mkIntCLit liveness_mask,
+ COffset words_required,
+ mkIntCLit (if node_reqd then 1 else 0)]
-- Emit macro for simulating a fetch and then reschedule
fetchAndReschedule :: [MagicId] -- Live registers
- -> Bool -- Node reqd
- -> Code
+ -> Bool -- Node reqd
+ -> Code
fetchAndReschedule regs node_reqd =
if (node `elem` regs || node_reqd)
then fetch_code `thenC` reschedule_code
else absC AbsCNop
where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ all_regs = if node_reqd then node:regs else regs
+ liveness_mask = mkLiveRegsBitMask all_regs
- reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
- mkIntCLit liveness_mask,
- mkIntCLit (if node_reqd then 1 else 0)])
+ reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
+ mkIntCLit liveness_mask,
+ mkIntCLit (if node_reqd then 1 else 0)])
- --HWL: generate GRAN_FETCH macro for GrAnSim
- -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
- fetch_code = absC (CMacroStmt GRAN_FETCH [])
+ --HWL: generate GRAN_FETCH macro for GrAnSim
+ -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
+ fetch_code = absC (CMacroStmt GRAN_FETCH [])
#endif {- GRAN -}
\end{code}
let info_offset = addOff virtHp (intOff 1)
-- do_move IS THE ASSIGNMENT FUNCTION
- do_move (amode, offset_from_start)
+ do_move (amode, offset_from_start)
= CAssign (CVal (HpRel realHp
(info_offset `addOff` offset_from_start))
- (getAmodeKind amode))
+ (getAmodeRep amode))
amode
in
-- SAY WHAT WE ARE ABOUT TO DO
-- GENERATE CC PROFILING MESSAGES
costCentresC SLIT("CC_ALLOC") [blame_cc,
COffset closure_size,
- CLitLit (_PK_ (closureKind closure_info)) IntKind]
+ CLitLit (_PK_ (closureKind closure_info)) IntRep]
`thenC`
-- BUMP THE VIRTUAL HEAP POINTER
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgLetNoEscape where
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, EndOfBlockInfo)
-import CostCentre(CostCentre)
-import Id(Id)
-import Maybes(Labda)
-import StgSyn(StgBinderInfo, StgExpr)
-import UniqFM(UniqFM)
-cgLetNoEscapeClosure :: Id -> CostCentre -> StgBinderInfo -> UniqFM Id -> EndOfBlockInfo -> Labda Int -> [Id] -> StgExpr Id Id -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
-
import CgRetConv ( assignRegs )
import CgStackery ( mkVirtStkOffsets )
import CgUsages ( setRealAndVirtualSps, getVirtSps )
-import CLabelInfo ( mkStdEntryLabel )
+import CLabel ( mkStdEntryLabel )
import ClosureInfo ( mkLFLetNoEscape )
-import Id ( getIdKind )
+import Id ( getIdPrimRep )
import Util
\end{code}
Consider:
\begin{verbatim}
let x = fvs \ args -> e
- in
- if ... then x else
+ in
+ if ... then x else
if ... then x else ...
\end{verbatim}
@x@ is used twice (so we probably can't unfold it), but when it is
@x@ can even be recursive! Eg:
\begin{verbatim}
letrec x = [y] \ [v] -> if v then x True else ...
- in
+ in
...(x b)...
\end{verbatim}
:: Id -- binder
-> CostCentre -- NB: *** NOT USED *** ToDo (WDP 94/06)
-> StgBinderInfo -- NB: ditto
- -> PlainStgLiveVars -- variables live in RHS, including the binders
+ -> StgLiveVars -- variables live in RHS, including the binders
-- themselves in the case of a recursive group
- -> EndOfBlockInfo -- where are we going to?
- -> Maybe VirtualSpBOffset -- Slot for current cost centre
+ -> EndOfBlockInfo -- where are we going to?
+ -> Maybe VirtualSpBOffset -- Slot for current cost centre
-> [Id] -- args (as in \ args -> body)
- -> PlainStgExpr -- body (as in above)
+ -> StgExpr -- body (as in above)
-> FCode (Id, CgIdInfo)
-- ToDo: deal with the cost-centre issues
arity = length args
lf_info = mkLFLetNoEscape arity full_live_in_rhss{-used???-}
in
- forkEvalHelp
- rhs_eob_info
+ forkEvalHelp
+ rhs_eob_info
(nukeDeadBindings full_live_in_rhss)
- (forkAbsC (cgLetNoEscapeBody args body))
+ (forkAbsC (cgLetNoEscapeBody args body))
`thenFC` \ (vA, vB, code) ->
let
label = mkStdEntryLabel binder -- arity
in
- absC (CCodeBlock label code) `thenC`
+ absC (CCodeBlock label code) `thenC`
returnFC (binder, letNoEscapeIdInfo binder vA vB lf_info)
\end{code}
\begin{code}
cgLetNoEscapeBody :: [Id] -- Args
- -> PlainStgExpr -- Body
+ -> StgExpr -- Body
-> Code
cgLetNoEscapeBody all_args rhs
= getVirtSps `thenFC` \ (vA, vB) ->
getIntSwitchChkrC `thenFC` \ isw_chkr ->
let
- arg_kinds = map getIdKind all_args
+ arg_kinds = map getIdPrimRep all_args
(arg_regs, _) = assignRegs isw_chkr [{-nothing live-}] arg_kinds
stk_args = drop (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
(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
- = mkVirtStkOffsets
+ = mkVirtStkOffsets
vA vB -- Initial virtual SpA, SpB
- getIdKind
+ getIdPrimRep
stk_args
in
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgMonad where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgBindings(..), CgIdInfo, StableLoc, VolatileLoc, heapIdInfo, stableAmodeIdInfo)
-import ClosureInfo(ClosureInfo, LambdaFormInfo)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre, IsCafCC)
-import HeapOffs(HeapOffset, VirtualHeapOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..))
-import Id(DataCon(..), Id)
-import IdEnv(IdEnv(..))
-import Maybes(Labda)
-import Outputable(NamedThing, Outputable)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import StgSyn(PlainStgLiveVars(..))
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-infixr 9 `thenC`
-infixr 9 `thenFC`
-type AStackUsage = (Int, [(Int, StubFlag)], Int, Int)
-data AbstractC
-type BStackUsage = (Int, [Int], Int, Int)
-data CAddrMode
-data CLabel
-type CgBindings = UniqFM CgIdInfo
-data CgIdInfo
-data CgInfoDownwards = MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo
-data CgState = MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset))
-type Code = CgInfoDownwards -> CgState -> CgState
-data CompilationInfo = MkCompInfo (GlobalSwitch -> Bool) ((Int -> GlobalSwitch) -> Labda Int) _PackedString
-data CostCentre
-data EndOfBlockInfo = EndOfBlockInfo Int Int Sequel
-type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
-data GlobalSwitch
-data HeapOffset
-type HeapUsage = (HeapOffset, HeapOffset)
-type IntSwitchChecker = (Int -> GlobalSwitch) -> Labda Int
-data LambdaFormInfo
-data IsCafCC
-type SemiTaggingStuff = Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel)))
-data Sequel = InRetReg | OnStack Int | UpdateCode CAddrMode | CaseAlts CAddrMode (Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel))))
-data StubFlag
-type VirtualHeapOffset = HeapOffset
-type VirtualSpAOffset = Int
-type VirtualSpBOffset = Int
-type DataCon = Id
-data Id
-type IdEnv a = UniqFM a
-data Labda a
-type PlainStgLiveVars = UniqFM Id
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-absC :: AbstractC -> CgInfoDownwards -> CgState -> CgState
-addBindC :: Id -> CgIdInfo -> CgInfoDownwards -> CgState -> CgState
-addBindsC :: [(Id, CgIdInfo)] -> CgInfoDownwards -> CgState -> CgState
-addFreeBSlots :: [Int] -> [Int] -> [Int]
-costCentresC :: _PackedString -> [CAddrMode] -> CgInfoDownwards -> CgState -> CgState
-costCentresFlag :: CgInfoDownwards -> CgState -> (Bool, CgState)
-fixC :: (a -> CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> (a, CgState)
-forkAbsC :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> (AbstractC, CgState)
-forkAlts :: [CgInfoDownwards -> CgState -> (a, CgState)] -> [CgInfoDownwards -> CgState -> (a, CgState)] -> (CgInfoDownwards -> CgState -> (b, CgState)) -> CgInfoDownwards -> CgState -> (([a], b), CgState)
-forkClosureBody :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-forkEval :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> (Sequel, CgState)) -> CgInfoDownwards -> CgState -> (EndOfBlockInfo, CgState)
-forkEvalHelp :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> ((Int, Int, a), CgState)
-forkStatics :: (CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> (a, CgState)
-getAbsC :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> (AbstractC, CgState)
-getEndOfBlockInfo :: CgInfoDownwards -> CgState -> (EndOfBlockInfo, CgState)
-getIntSwitchChkrC :: CgInfoDownwards -> CgState -> ((Int -> GlobalSwitch) -> Labda Int, CgState)
-getUnstubbedAStackSlots :: Int -> CgInfoDownwards -> CgState -> ([Int], CgState)
-heapIdInfo :: Id -> HeapOffset -> LambdaFormInfo -> CgIdInfo
-initC :: CompilationInfo -> (CgInfoDownwards -> CgState -> CgState) -> AbstractC
-isStringSwitchSetC :: ([Char] -> GlobalSwitch) -> CgInfoDownwards -> CgState -> (Bool, CgState)
-isStubbed :: StubFlag -> Bool
-isSwitchSetC :: GlobalSwitch -> CgInfoDownwards -> CgState -> (Bool, CgState)
-listCs :: [CgInfoDownwards -> CgState -> CgState] -> CgInfoDownwards -> CgState -> CgState
-listFCs :: [CgInfoDownwards -> CgState -> (a, CgState)] -> CgInfoDownwards -> CgState -> ([a], CgState)
-lookupBindC :: Id -> CgInfoDownwards -> CgState -> (CgIdInfo, CgState)
-mapCs :: (a -> CgInfoDownwards -> CgState -> CgState) -> [a] -> CgInfoDownwards -> CgState -> CgState
-mapFCs :: (a -> CgInfoDownwards -> CgState -> (b, CgState)) -> [a] -> CgInfoDownwards -> CgState -> ([b], CgState)
-modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> CgInfoDownwards -> CgState -> CgState
-moduleName :: CgInfoDownwards -> CgState -> (_PackedString, CgState)
-noBlackHolingFlag :: CgInfoDownwards -> CgState -> (Bool, CgState)
-nopC :: CgInfoDownwards -> CgState -> CgState
-nukeDeadBindings :: UniqFM Id -> CgInfoDownwards -> CgState -> CgState
-profCtrC :: _PackedString -> [CAddrMode] -> CgInfoDownwards -> CgState -> CgState
-returnFC :: a -> CgInfoDownwards -> CgState -> (a, CgState)
-sequelToAmode :: Sequel -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
-setEndOfBlockInfo :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-stableAmodeIdInfo :: Id -> CAddrMode -> LambdaFormInfo -> CgIdInfo
-thenC :: (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> a) -> CgInfoDownwards -> CgState -> a
-thenFC :: (CgInfoDownwards -> CgState -> (a, CgState)) -> (a -> CgInfoDownwards -> CgState -> b) -> CgInfoDownwards -> CgState -> b
-instance Eq CLabel
-instance Eq GlobalSwitch
-instance Eq Id
-instance Eq Unique
-instance Ord CLabel
-instance Ord GlobalSwitch
-instance Ord Id
-instance Ord Unique
-instance NamedThing Id
-instance Outputable Id
-instance Text Unique
-
SemiTaggingStuff(..),
addBindC, addBindsC, modifyBindC, lookupBindC,
---UNUSED: grabBindsC,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
AStackUsage(..), BStackUsage(..), HeapUsage(..),
StubFlag,
isStubbed,
---UNUSED: grabStackSizeC,
nukeDeadBindings, getUnstubbedAStackSlots,
isSwitchSetC, isStringSwitchSetC, getIntSwitchChkrC,
noBlackHolingFlag,
- profCtrC, --UNUSED: concurrentC,
+ profCtrC,
costCentresC, costCentresFlag, moduleName,
CgInfoDownwards(..), CgState(..), -- non-abstract
CgIdInfo, -- abstract
CompilationInfo(..), IntSwitchChecker(..),
- GlobalSwitch, -- abstract
- stableAmodeIdInfo, heapIdInfo,
+ stableAmodeIdInfo, heapIdInfo
-- and to make the interface self-sufficient...
- AbstractC, CAddrMode, CLabel, LambdaFormInfo, IdEnv(..),
- Unique, HeapOffset, CostCentre, IsCafCC,
- Id, UniqSet(..), UniqFM,
- VirtualSpAOffset(..), VirtualSpBOffset(..),
- VirtualHeapOffset(..), DataCon(..), PlainStgLiveVars(..),
- Maybe
) where
import AbsCSyn
-import AbsUniType ( kindFromType, UniType
+import Type ( primRepFromType, Type
IF_ATTACK_PRAGMAS(COMMA cmpUniType)
)
import CgBindery
import CgUsages ( getSpBRelOffset )
import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( getIdUniType, ConTag(..), DataCon(..) )
-import IdEnv -- ops on CgBindings use these
+import Id ( idType, ConTag(..), DataCon(..) )
import Maybes ( catMaybes, maybeToBool, Maybe(..) )
import Pretty -- debugging only?
-import PrimKind ( getKindSize, retKindSize )
+import PrimRep ( getPrimRepSize, retPrimRepSize )
import UniqSet -- ( elementOfUniqSet, UniqSet(..) )
import CostCentre -- profiling stuff
-import StgSyn ( PlainStgAtom(..), PlainStgLiveVars(..) )
-import Unique ( UniqueSupply )
+import StgSyn ( StgArg(..), StgLiveVars(..) )
import Util
infixr 9 `thenC` -- Right-associative!
data CompilationInfo
= MkCompInfo
- (GlobalSwitch -> Bool)
- -- use it to look up whatever we like in command-line flags
- IntSwitchChecker-- similar; for flags that have an Int assoc.
- -- with them, notably number of regs available.
FAST_STRING -- the module name
-type IntSwitchChecker = (Int -> GlobalSwitch) -> Maybe Int
-
data CgState
= MkCgState
AbstractC -- code accumulated so far
-- push arguments starting just above this point on
-- a tail call.
- -- This is therefore the A-stk ptr as seen
+ -- This is therefore the A-stk ptr as seen
-- by a case alternative.
- -- Args SpA is used when we want to stub any
+ -- Args SpA is used when we want to stub any
-- currently-unstubbed dead A-stack (ptr) slots;
-- we want to know what SpA in the continuation is
-- so that we don't stub any slots which are off the
VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
-- Two main differences:
- -- 1. If Sequel isn't OnStack, then Args SpB points
+ -- 1. If Sequel isn't OnStack, then Args SpB points
-- just below the slot in which the return address
-- should be put. In effect, the Sequel is
-- a pending argument. If it is OnStack, Args SpB
--
-- 2. It ain't used for stubbing because there are
-- no ptrs on B stk.
-
+
Sequel
\begin{code}
data Sequel
- = InRetReg -- The continuation is in RetReg
-
- | OnStack VirtualSpBOffset
- -- Continuation is on the stack, at the
- -- specified location
-
+ = InRetReg -- The continuation is in RetReg
---UNUSED: | RestoreCostCentre
+ | OnStack VirtualSpBOffset
+ -- Continuation is on the stack, at the
+ -- specified location
| UpdateCode CAddrMode -- May be standard update code, or might be
-- the data-type-specific one.
- | CaseAlts
+ | CaseAlts
CAddrMode -- Jump to this; if the continuation is for a vectored
-- case this might be the label of a return vector
-- Guaranteed to be a non-volatile addressing mode (I think)
)
type JoinDetails
- = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
+ = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
-- and join point label
-- The abstract C is executed only from a successful
-- semitagging venture, when a case has looked at a variable, found
-- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only valid
+-- The OnStack case of sequelToAmode delivers an Amode which is only valid
-- just before the final control transfer, because it assumes that
-- SpB is pointing to the top word of the return address.
-- This seems unclean but there you go.
sequelToAmode (OnStack virt_spb_offset)
= getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
- returnFC (CVal spb_rel RetKind)
+ returnFC (CVal spb_rel RetRep)
sequelToAmode InRetReg = returnFC (CReg RetReg)
---UNUSED:sequelToAmode RestoreCostCentre = returnFC mkRestoreCostCentreLbl
--Andy/Simon's patch:
--WAS: sequelToAmode (UpdateCode amode) = returnFC amode
sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
sequelToAmode (CaseAlts amode _) = returnFC amode
-
--- ToDo: move/do something
---UNUSED:mkRestoreCostCentreLbl = panic "mkRestoreCostCentreLbl"
\end{code}
See the NOTES about the details of stack/heap usage tracking.
stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
(MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
= MkCgState abs_c
- bs
+ bs
((vA,fA,rA,hA1 `max` hA2),
(vB,fB,rB,hB1 `max` hB2),
(vH1 `maxOff` vH2, rH1))
type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
type Code = CgInfoDownwards -> CgState -> CgState
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenC #-}
{-# INLINE thenFC #-}
{-# INLINE returnFC #-}
-#endif
\end{code}
The Abstract~C is not in the environment so as to improve strictness.
\begin{code}
forkClosureBody :: Code -> Code
-forkClosureBody code
- (MkCgInfoDown cg_info statics _)
+forkClosureBody code
+ (MkCgInfoDown cg_info statics _)
(MkCgState absC_in binds un_usage)
= MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
where
forkAbsC code info_down (MkCgState absC1 bs usage)
= (absC2, new_state)
where
- MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
+ MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
code info_down (MkCgState AbsCNop bs usage)
((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
C1 a b -> e1
z -> e2
-Here we in effect expand to
+Here we in effect expand to
- case f x of
+ case f x of
C1 a b -> e1
C2 c -> let z = C2 c in JUMP(default)
C3 d e f -> let z = C2 d e f in JUMP(default)
-
+
default: e2
The stuff for C2 and C3 are the extra branches. They are
-> FCode Sequel -- Semi-tagging info to store
-> FCode EndOfBlockInfo -- The new end of block info
-forkEval body_eob_info env_code body_code
+forkEval body_eob_info env_code body_code
= forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
returnFC (EndOfBlockInfo vA vB sequel)
-forkEvalHelp :: EndOfBlockInfo -- For the body
+forkEvalHelp :: EndOfBlockInfo -- For the body
-> Code -- Code to set environment
-> FCode a -- The code to do after the eval
-> FCode (Int, -- SpA
Int, -- SpB
a) -- Result of the FCode
-forkEvalHelp body_eob_info env_code body_code
+forkEvalHelp body_eob_info env_code body_code
info_down@(MkCgInfoDown cg_info statics _) state
= ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
where
state_for_body = MkCgState AbsCNop
(nukeVolatileBinds binds)
- ((vA,stubbed_fA,vA,vA), -- Set real and hwms
+ ((vA,stubbed_fA,vA,vA), -- Set real and hwms
(vB,fB,vB,vB), -- to virtual ones
(initVirtHp, initRealHp))
stateIncUsageEval :: CgState -> CgState -> CgState
stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
(MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
- = MkCgState (absC1 `AbsCStmts` absC2)
+ = MkCgState (absC1 `AbsCStmts` absC2)
-- The AbsC coming back should consist only of nested declarations,
-- notably of the return vector!
- bs
+ bs
((vA,fA,rA,hA1 `max` hA2),
(vB,fB,rB,hB1 `max` hB2),
heap_usage)
nothing.
\begin{code}
-isSwitchSetC :: GlobalSwitch -> FCode Bool
-
-isSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr switch, state)
-
-isStringSwitchSetC :: (String -> GlobalSwitch) -> FCode Bool
-
-isStringSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr (switch (panic "isStringSwitchSetC")), state)
-
-getIntSwitchChkrC :: FCode IntSwitchChecker
-
-getIntSwitchChkrC (MkCgInfoDown (MkCompInfo _ isw_chkr _) _ _) state
- = (isw_chkr, state)
-
costCentresC :: FAST_STRING -> [CAddrMode] -> Code
costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
then state
else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
-{- Try to avoid adding too many special compilation strategies here.
- It's better to modify the header files as necessary for particular targets,
- so that we can get away with as few variants of .hc files as possible.
- 'ForConcurrent' is somewhat special anyway, as it changes entry conventions
- pretty significantly.
--}
-
--- if compiling for concurrency...
-
-{- UNUSED, as it happens:
-concurrentC :: AbstractC -> Code
-
-concurrentC more_absC (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
- state@(MkCgState absC binds usage)
- = if not (sw_chkr ForConcurrent)
- then state
- else MkCgState (mkAbsCStmts absC more_absC) binds usage
+{- Try to avoid adding too many special compilation strategies here.
+ It's better to modify the header files as necessary for particular
+ targets, so that we can get away with as few variants of .hc files
+ as possible. 'ForConcurrent' is somewhat special anyway, as it
+ changes entry conventions pretty significantly.
-}
\end{code}
Lookup is expected to find a binding for the @Id@.
\begin{code}
lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
+lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
state@(MkCgState absC local_binds usage)
= (val, state)
where
])
\end{code}
-For dumping debug information, we also have the ability to grab the
-local bindings environment.
-
-ToDo: Maybe do the pretty-printing here to restrict what people do
-with the environment.
-
-\begin{code}
-{- UNUSED:
-grabBindsC :: FCode CgBindings
-grabBindsC info_down state@(MkCgState absC binds usage)
- = (binds, state)
--}
-\end{code}
-
-\begin{code}
-{- UNUSED:
-grabStackSizeC :: FCode (Int, Int)
-grabStackSizeC info_down state -- @(MkCgState absC binds ((vA,_,_,_), (vB,_,_,_), _))
- = panic "grabStackSizeC" -- (vA, vB)
--}
-\end{code}
-
%************************************************************************
%* *
\subsection[CgStackery-deadslots]{Finding dead stack slots}
Probably *naughty* to look inside monad...
\begin{code}
-nukeDeadBindings :: PlainStgLiveVars -- All the *live* variables
+nukeDeadBindings :: StgLiveVars -- All the *live* variables
-> Code
nukeDeadBindings
live_vars
heap_usage)
(dead_a_slots, dead_b_slots, bs')
- = dead_slots live_vars
- [] [] []
+ = dead_slots live_vars
+ [] [] []
[ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
- --OLD: (getIdEnvMapping binds)
extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
extra_free_b = sortLt (<) dead_b_slots
Several boring auxiliary functions to do the dirty work.
\begin{code}
-dead_slots :: PlainStgLiveVars
+dead_slots :: StgLiveVars
-> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
-> [(Id,CgIdInfo)]
-> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
_ -> dead_slots live_vars fbs das dbs bs
where
size :: Int
- size = (getKindSize . kindFromType . getIdUniType) v
+ size = (getPrimRepSize . primRepFromType . idType) v
-- addFreeSlots expects *both* args to be in increasing order
addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgRetConv where
-import AbsCSyn(AbstractC, CAddrMode, MagicId)
-import CLabelInfo(CLabel)
-import CmdLineOpts(GlobalSwitch)
-import Id(Id)
-import Maybes(Labda)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import TyCon(TyCon)
-data MagicId
-data CLabel
-data CtrlReturnConvention = VectoredReturn Int | UnvectoredReturn Int
-data DataReturnConvention = ReturnInHeap | ReturnInRegs [MagicId]
-data Id
-data PrimKind
-data TyCon
-assignPrimOpResultRegs :: PrimOp -> [MagicId]
-assignRegs :: ((Int -> GlobalSwitch) -> Labda Int) -> [MagicId] -> [PrimKind] -> ([MagicId], [PrimKind])
-ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
-dataReturnConvAlg :: ((Int -> GlobalSwitch) -> Labda Int) -> Id -> DataReturnConvention
-dataReturnConvPrim :: PrimKind -> MagicId
-makePrimOpArgsRobust :: PrimOp -> [CAddrMode] -> ([CAddrMode], Int, AbstractC)
-mkLiveRegsBitMask :: [MagicId] -> Int
-noLiveRegsMask :: Int
-
assignPrimOpResultRegs,
makePrimOpArgsRobust,
- assignRegs,
+ assignRegs
-- and to make the interface self-sufficient...
- MagicId, PrimKind, Id, CLabel, TyCon
) where
import AbsCSyn
-import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC,
- getPrimOpResultInfo, integerDataCon, PrimKind
+import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC,
+ getPrimOpResultInfo, integerDataCon
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( getTyConFamilySize, kindFromType, getTyConDataCons,
+import Type ( getTyConFamilySize, primRepFromType, getTyConDataCons,
TyVarTemplate, TyCon, Class,
- TauType(..), ThetaType(..), UniType
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+ TauType(..), ThetaType(..), Type
)
import CgCompInfo -- various things
import CgMonad ( IntSwitchChecker(..) )
DataCon(..), ConTag(..)
)
import Maybes ( catMaybes, Maybe(..) )
-import PrimKind
+import PrimRep
import Util
import Pretty
\end{code}
\begin{code}
data DataReturnConvention
= ReturnInHeap
- | ReturnInRegs [MagicId]
+ | ReturnInRegs [MagicId]
\end{code}
The register assignment given by a @ReturnInRegs@ obeys three rules:
\begin{itemize}
(reg_assignment, leftover_kinds)
= assignRegs isw_chkr_to_use
[node, infoptr] -- taken...
- (map kindFromType arg_tys)
-
+ (map primRepFromType arg_tys)
+
isw_chkr_to_use = isw_chkr
-{-OLD:
- = if is_prim_result_ty {-and therefore *ignore* any return-in-regs threshold-}
- then \ x -> Nothing
- else isw_chkr
--}
+
is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11)
\end{code}
= foldl do_reg noLiveRegsMask regs
where
do_reg acc (VanillaReg kind reg_no)
- | isFollowableKind kind
+ | isFollowableRep kind
= acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1)))
do_reg acc anything_else = acc
= foldl (+) noLiveRegsMask (map liveness_bit regs)
where
liveness_bit (VanillaReg kind reg_no)
- | isFollowableKind kind
+ | isFollowableRep kind
= reg_tbl !! (reg_no - 1)
- liveness_bit anything_else
+ liveness_bit anything_else
= noLiveRegsBitMask
reg_tbl
make sure you alter CgCase (cgPrimDefault) to generate the right sort
of heap check!
\begin{code}
-dataReturnConvPrim :: PrimKind -> MagicId
+dataReturnConvPrim :: PrimRep -> MagicId
-#ifndef DPH
-dataReturnConvPrim IntKind = VanillaReg IntKind ILIT(1)
-dataReturnConvPrim WordKind = VanillaReg WordKind ILIT(1)
-dataReturnConvPrim AddrKind = VanillaReg AddrKind ILIT(1)
-dataReturnConvPrim CharKind = VanillaReg CharKind ILIT(1)
-dataReturnConvPrim FloatKind = FloatReg ILIT(1)
-dataReturnConvPrim DoubleKind = DoubleReg ILIT(1)
-dataReturnConvPrim VoidKind = VoidReg
+dataReturnConvPrim IntRep = VanillaReg IntRep ILIT(1)
+dataReturnConvPrim WordRep = VanillaReg WordRep ILIT(1)
+dataReturnConvPrim AddrRep = VanillaReg AddrRep ILIT(1)
+dataReturnConvPrim CharRep = VanillaReg CharRep ILIT(1)
+dataReturnConvPrim FloatRep = FloatReg ILIT(1)
+dataReturnConvPrim DoubleRep = DoubleReg ILIT(1)
+dataReturnConvPrim VoidRep = VoidReg
-- Return a primitive-array pointer in the usual register:
-dataReturnConvPrim ArrayKind = VanillaReg ArrayKind ILIT(1)
-dataReturnConvPrim ByteArrayKind = VanillaReg ByteArrayKind ILIT(1)
+dataReturnConvPrim ArrayRep = VanillaReg ArrayRep ILIT(1)
+dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1)
-dataReturnConvPrim StablePtrKind = VanillaReg StablePtrKind ILIT(1)
-dataReturnConvPrim MallocPtrKind = VanillaReg MallocPtrKind ILIT(1)
+dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1)
+dataReturnConvPrim MallocPtrRep = VanillaReg MallocPtrRep ILIT(1)
-dataReturnConvPrim PtrKind = panic "dataReturnConvPrim: PtrKind"
+#ifdef DEBUG
+dataReturnConvPrim PtrRep = panic "dataReturnConvPrim: PtrRep"
dataReturnConvPrim _ = panic "dataReturnConvPrim: other"
-
-#else
-dataReturnConvPrim VoidKind = VoidReg
-dataReturnConvPrim PtrKind = panic "dataReturnConvPrim: PtrKind"
-dataReturnConvPrim kind = DataReg kind 2 -- Don't Hog a Modifier reg.
-#endif {- Data Parallel Haskell -}
+#endif
\end{code}
-
%********************************************************
%* *
\subsection[primop-stuff]{Argument and return conventions for Prim Ops}
-- As R1 is dead, it can hold the tag if necessary
case cons of
[_] -> result_regs
- other -> (VanillaReg IntKind ILIT(1)) : result_regs
+ other -> (VanillaReg IntRep ILIT(1)) : result_regs
where
get_return_regs con
= case (dataReturnConvAlg fake_isw_chkr con) of
= ASSERT (primOpCanTriggerGC op)
let
non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes
- arg_kinds = map getAmodeKind non_robust_amodes
+ arg_kinds = map getAmodeRep non_robust_amodes
(arg_regs, extra_args)
= assignRegs fake_isw_chkr [{-nothing live-}] arg_kinds
[] -> arg_regs
other -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op))
- arg_assts = mkAbstractCs (zipWith assign_to_reg final_arg_regs non_robust_amodes)
+ arg_assts
+ = mkAbstractCs (zipWithEqual assign_to_reg final_arg_regs non_robust_amodes)
+
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
- safe_arg regs arg
- | amodeCanSurviveGC arg = (regs, arg)
+ safe_arg regs arg
+ | amodeCanSurviveGC arg = (regs, arg)
| otherwise = (tail regs, CReg (head regs))
safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes)
\begin{code}
assignRegs :: IntSwitchChecker
-> [MagicId] -- Unavailable registers
- -> [PrimKind] -- Arg or result kinds to assign
+ -> [PrimRep] -- Arg or result kinds to assign
-> ([MagicId], -- Register assignment in same order
-- for *initial segment of* input list
- [PrimKind])-- leftover kinds
+ [PrimRep])-- leftover kinds
assignRegs isw_chkr regs_in_use kinds
= assign_reg kinds [] (mkRegTbl isw_chkr regs_in_use)
where
- assign_reg :: [PrimKind] -- arg kinds being scrutinized
+ assign_reg :: [PrimRep] -- arg kinds being scrutinized
-> [MagicId] -- accum. regs assigned so far (reversed)
-> ([Int], [Int], [Int])
-- regs still avail: Vanilla, Float, Double
- -> ([MagicId], [PrimKind])
+ -> ([MagicId], [PrimRep])
- assign_reg (VoidKind:ks) acc supply
+ assign_reg (VoidRep:ks) acc supply
= assign_reg ks (VoidReg:acc) supply -- one VoidReg is enough for everybody!
- assign_reg (FloatKind:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs)
+ assign_reg (FloatRep:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs)
= assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs)
- assign_reg (DoubleKind:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs)
+ assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs)
= assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs)
assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs)
- | not (isFloatingKind k)
+ | not (isFloatingRep k)
= assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs)
-- The catch-all. It can happen because either
mkRegTbl isw_chkr regs_in_use
= (ok_vanilla, ok_float, ok_double)
where
- ok_vanilla = catMaybes (map (select (VanillaReg VoidKind)) (taker vanillaRegNos))
+ ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) (taker vanillaRegNos))
ok_float = catMaybes (map (select FloatReg) floatRegNos)
ok_double = catMaybes (map (select DoubleReg) doubleRegNos)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgStackery where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data AbstractC
-data CAddrMode
-data CgState
-data PrimKind
-adjustRealSps :: Int -> Int -> CgInfoDownwards -> CgState -> CgState
-allocAStack :: CgInfoDownwards -> CgState -> (Int, CgState)
-allocBStack :: Int -> CgInfoDownwards -> CgState -> (Int, CgState)
-allocUpdateFrame :: Int -> CAddrMode -> ((Int, Int, Int) -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-getFinalStackHW :: (Int -> Int -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-mkStkAmodes :: Int -> Int -> [CAddrMode] -> CgInfoDownwards -> CgState -> ((Int, Int, AbstractC), CgState)
-mkVirtStkOffsets :: Int -> Int -> (a -> PrimKind) -> [a] -> (Int, Int, [(a, Int)], [(a, Int)])
-
module CgStackery (
allocAStack, allocBStack, allocUpdateFrame,
adjustRealSps, getFinalStackHW,
- mkVirtStkOffsets, mkStkAmodes,
+ mkVirtStkOffsets, mkStkAmodes
-- and to make the interface self-sufficient...
- AbstractC, CAddrMode, CgState, PrimKind
) where
import StgSyn
import CgUsages ( getSpBRelOffset )
import Maybes ( Maybe(..) )
-import PrimKind ( getKindSize, retKindSize, separateByPtrFollowness )
+import PrimRep ( getPrimRepSize, retPrimRepSize, separateByPtrFollowness )
import Util
\end{code}
\begin{code}
mkVirtStkOffsets :: VirtualSpAOffset -- Offset of the last allocated thing
-> VirtualSpBOffset -- ditto
- -> (a -> PrimKind) -- to be able to grab kinds
+ -> (a -> PrimRep) -- to be able to grab kinds
-> [a] -- things to make offsets for
-> (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
VirtualSpBOffset, -- ditto
(last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
where
computeOffset offset thing
- = (offset + (getKindSize . kind_fun) thing, (thing, offset+(1::Int)))
+ = (offset + (getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
\end{code}
@mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
-> [CAddrMode] -- things to make offsets for
-> FCode (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
VirtualSpBOffset, -- ditto
- AbstractC) -- Assignments to appropriate stk slots
+ AbstractC) -- Assignments to appropriate stk slots
mkStkAmodes tail_spa tail_spb things
info_down (MkCgState absC binds usage)
result = (last_SpA_offset, last_SpB_offset, mkAbstractCs abs_cs)
(last_SpA_offset, last_SpB_offset, ptrs_w_offsets, non_ptrs_w_offsets)
- = mkVirtStkOffsets tail_spa tail_spb getAmodeKind things
+ = mkVirtStkOffsets tail_spa tail_spb getAmodeRep things
abs_cs
- = [ CAssign (CVal (SpARel realSpA offset) PtrKind) thing
+ = [ CAssign (CVal (SpARel realSpA offset) PtrRep) thing
| (thing, offset) <- ptrs_w_offsets
]
++
- [ CAssign (CVal (SpBRel realSpB offset) (getAmodeKind thing)) thing
+ [ CAssign (CVal (SpBRel realSpB offset) (getAmodeRep thing)) thing
| (thing, offset) <- non_ptrs_w_offsets
]
allocUpdateFrame :: Int -- Size of frame
-> CAddrMode -- Return address which is to be the
-- top word of frame
- -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code)
+ -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code)
-- Scope of update
-> Code
= MkCgState (mkAbsCStmts absC move_instrB) binds new_usage
where
move_instrB = if (newRealSpB == realSpB) then AbsCNop
- else (CAssign {-PtrKind-}
+ else (CAssign {-PtrRep-}
(CReg SpB)
(CAddr (SpBRel realSpB newRealSpB)))
new_usage = (a_usage,
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgTailCall where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, MagicId, RegRelative)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, Sequel, StubFlag)
-import ClosureInfo(LambdaFormInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import StgSyn(StgAtom)
-import TyCon(TyCon)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CAddrMode
-data CgInfoDownwards
-data CgState
-data HeapOffset
-data Id
-data Labda a
-data StgAtom a
-data TyCon
-cgTailCall :: StgAtom Id -> [StgAtom Id] -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState
-mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> CgInfoDownwards -> CgState -> CgState
-mkPrimReturnCode :: Sequel -> CgInfoDownwards -> CgState -> CgState
-mkStaticAlgReturnCode :: Id -> Labda CLabel -> Sequel -> CgInfoDownwards -> CgState -> CgState
-performReturn :: AbstractC -> (Sequel -> CgInfoDownwards -> CgState -> CgState) -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState
-tailCallBusiness :: Id -> CAddrMode -> LambdaFormInfo -> [CAddrMode] -> UniqFM Id -> AbstractC -> CgInfoDownwards -> CgState -> CgState
-
performReturn,
mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
mkPrimReturnCode,
-
- tailCallBusiness,
+
+ tailCallBusiness
-- and to make the interface self-sufficient...
- StgAtom, Id, CgState, CAddrMode, TyCon,
- CgInfoDownwards, HeapOffset, Maybe
) where
IMPORT_Trace
import CgMonad
import AbsCSyn
-import AbsUniType ( isPrimType, UniType )
+import Type ( isPrimType, Type )
import CgBindery ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
import CgCompInfo ( oTHER_TAG, iND_TAG )
import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
)
import CgStackery ( adjustRealSps, mkStkAmodes )
import CgUsages ( getSpARelOffset, getSpBRelOffset )
-import CLabelInfo ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
+import CLabel ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) )
import CmdLineOpts ( GlobalSwitch(..) )
import Id ( getDataConTyCon, getDataConTag,
- getIdUniType, getIdKind, fIRST_TAG, Id,
+ idType, getIdPrimRep, fIRST_TAG, Id,
ConTag(..)
)
import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import PrimKind ( retKindSize )
+import PrimRep ( retPrimRepSize )
import Util
\end{code}
%************************************************************************
\begin{code}
-cgTailCall :: PlainStgAtom -> [PlainStgAtom] -> PlainStgLiveVars -> Code
+cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code
\end{code}
Here's the code we generate for a tail call. (NB there may be no
top of the B stack.
\begin{code}
-cgTailCall (StgLitAtom lit) [] live_vars
+cgTailCall (StgLitArg lit) [] live_vars
= performPrimReturn (CLit lit) live_vars
\end{code}
Case for unboxed @Ids@ first:
\begin{code}
-cgTailCall atom@(StgVarAtom fun) [] live_vars
- | isPrimType (getIdUniType fun)
+cgTailCall atom@(StgVarArg fun) [] live_vars
+ | isPrimType (idType fun)
= getCAddrMode fun `thenFC` \ amode ->
performPrimReturn amode live_vars
\end{code}
The general case (@fun@ is boxed):
\begin{code}
-cgTailCall (StgVarAtom fun) args live_vars = performTailCall fun args live_vars
+cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars
\end{code}
%************************************************************************
\begin{code}
performPrimReturn :: CAddrMode -- The thing to return
- -> PlainStgLiveVars
+ -> StgLiveVars
-> Code
performPrimReturn amode live_vars
= let
- kind = getAmodeKind amode
+ kind = getAmodeRep amode
ret_reg = dataReturnConvPrim kind
assign_possibly = case kind of
- VoidKind -> AbsCNop
+ VoidRep -> AbsCNop
kind -> (CAssign (CReg ret_reg) amode)
in
performReturn assign_possibly mkPrimReturnCode live_vars
mkPrimReturnCode :: Sequel -> Code
---UNUSED:mkPrimReturnCode RestoreCostCentre = panic "mkPrimReturnCode: RCC"
-mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
-mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
- absC (CReturn dest_amode DirectReturn)
- -- Direct, no vectoring
+mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
+mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
+ absC (CReturn dest_amode DirectReturn)
+ -- Direct, no vectoring
-- All constructor arguments in registers; Node and InfoPtr are set.
-- All that remains is
-- Set the info pointer, and jump
set_info_ptr `thenC`
getIntSwitchChkrC `thenFC` \ isw_chkr ->
- absC (CJump (CLbl (update_label isw_chkr) CodePtrKind))
+ absC (CJump (CLbl (update_label isw_chkr) CodePtrRep))
CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
-- we can go right to the alternative
-- is going to handle.
case assocMaybe alts tag of
- Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrKind))
+ Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep))
Nothing -> panic "mkStaticAlgReturnCode: default"
-- The Nothing case should never happen; it's the subject
-- of a wad of special-case code in cgReturnCon
tycon = getDataConTyCon con
return_convention = ctrlReturnConvAlg tycon
zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
- -- cf AbsCFuns.mkAlgAltsCSwitch
+ -- cf AbsCUtils.mkAlgAltsCSwitch
update_label isw_chkr
= case (dataReturnConvAlg isw_chkr con) of
set_info_ptr = case maybe_info_lbl of
Nothing -> nopC
- Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrKind))
+ Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep))
mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
VectoredReturn sz ->
profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
- sequelToAmode sequel `thenFC` \ ret_addr ->
+ sequelToAmode sequel `thenFC` \ ret_addr ->
absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
UnvectoredReturn no_of_constrs ->
-> (Sequel -> Code) -- The code to execute to actually do
-- the return, given an addressing mode
-- for the return address
- -> PlainStgLiveVars
+ -> StgLiveVars
-> Code
performReturn sim_assts finish_code live_vars
= getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
-- Do the simultaneous assignments,
- doSimAssts args_spa live_vars {-UNUSED:live_regs-} sim_assts `thenC`
+ doSimAssts args_spa live_vars sim_assts `thenC`
-- Adjust stack pointers
adjustRealSps args_spa args_spb `thenC`
-- Do the return
finish_code sequel -- "sequel" is `robust' in that it doesn't
-- depend on stk-ptr values
--- where
---UNUSED: live_regs = getDestinationRegs sim_assts
- -- ToDo: this is a *really* boring way to compute the
- -- live-reg set!
\end{code}
\begin{code}
performTailCall :: Id -- Function
- -> [PlainStgAtom] -- Args
- -> PlainStgLiveVars
+ -> [StgArg] -- Args
+ -> StgLiveVars
-> Code
performTailCall fun args live_vars
tailCallBusiness :: Id -> CAddrMode -- Function and its amode
-> LambdaFormInfo -- Info about the function
-> [CAddrMode] -- Arguments
- -> PlainStgLiveVars -- Live in continuation
+ -> StgLiveVars -- Live in continuation
-> AbstractC -- Pending simultaneous assignments
-- *** GUARANTEED to contain only stack assignments.
nodeMustPointToIt lf_info `thenFC` \ node_points ->
getEntryConvention fun lf_info
- (map getAmodeKind arg_amodes) `thenFC` \ entry_conv ->
+ (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
CAssign (CReg infoptr)
- (CMacroExpr DataPtrKind INFO_PTR [CReg node]),
- CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr])
+ (CMacroExpr DataPtrRep INFO_PTR [CReg node]),
+ CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr])
])
- StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrKind))
- StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrKind)
+ StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep))
+ StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
`mkAbsCStmts`
- CJump (CLbl lbl CodePtrKind))
+ CJump (CLbl lbl CodePtrRep))
DirectEntry lbl arity regs ->
(regs, (if do_arity_chks
then CMacroStmt SET_ARITY [mkIntCLit arity]
else AbsCNop)
- `mkAbsCStmts` CJump (CLbl lbl CodePtrKind))
+ `mkAbsCStmts` CJump (CLbl lbl CodePtrRep))
no_of_args = length arg_amodes
-{- UNUSED: live_regs = if node_points then
- node : arg_regs
- else
- arg_regs
--}
(reg_arg_assts, stk_arg_amodes)
- = (mkAbstractCs (zipWith assign_to_reg arg_regs arg_amodes),
+ = (mkAbstractCs (zipWithEqual assign_to_reg arg_regs arg_amodes),
drop (length arg_regs) arg_amodes) -- No regs, or
-- args beyond arity
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-
in
case fun_amode of
CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
`thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
-- Do the simultaneous assignments,
- doSimAssts join_spa live_vars {-UNUSED: live_regs-}
+ doSimAssts join_spa live_vars
(mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
`thenC`
-- Make instruction to save return address
loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst ->
-
+
mkStkAmodes args_spa args_spb stk_arg_amodes
`thenFC`
\ (final_spa, final_spb, stk_arg_assts) ->
-- on top, is recorded in final_spb.
-- Do the simultaneous assignments,
- doSimAssts args_spa live_vars {-UNUSED: live_regs-}
+ doSimAssts args_spa live_vars
(mkAbstractCs [pending_assts, node_asst, ret_asst,
reg_arg_assts, stk_arg_assts])
`thenC`
let
join_details_to_code (load_regs_and_profiling_code, join_lbl)
= load_regs_and_profiling_code `mkAbsCStmts`
- CJump (CLbl join_lbl CodePtrKind)
+ CJump (CLbl join_lbl CodePtrRep)
semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
join_details_to_code join_details)
-- Enter Node (we know infoptr will have the info ptr in it)!
= mkAbstractCs [
CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
- [CMacroExpr IntKind INFO_TAG [CReg infoptr]],
- CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr]) ]
+ [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
+ CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
in
-- Final switch
absC (mkAbstractCs [
CAssign (CReg infoptr)
- (CVal (NodeRel zeroOff) DataPtrKind),
+ (CVal (NodeRel zeroOff) DataPtrRep),
case maybe_deflt_join_details of
Nothing ->
- CSwitch (CMacroExpr IntKind INFO_TAG [CReg infoptr])
+ CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
(semi_tagged_alts)
(enter_jump)
Just (_, details) ->
- CSwitch (CMacroExpr IntKind EVAL_TAG [CReg infoptr])
+ CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
[(mkMachInt 0, enter_jump)]
(CSwitch
- (CMacroExpr IntKind INFO_TAG [CReg infoptr])
+ (CMacroExpr IntRep INFO_TAG [CReg infoptr])
(semi_tagged_alts)
(join_details_to_code details))
])
\begin{code}
doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
- -> PlainStgLiveVars -- Live in continuation
---UNUSED: -> [MagicId] -- Live regs (ptrs and non-ptrs)
+ -> StgLiveVars -- Live in continuation
-> AbstractC
-> Code
-doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts
+doSimAssts tail_spa live_vars sim_assts
= -- Do the simultaneous assignments
absC (CSimultaneous sim_assts) `thenC`
where
stub_A_slot :: VirtualSpAOffset -> Code
stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
- absC (CAssign (CVal spa_rel PtrKind)
+ absC (CAssign (CVal spa_rel PtrRep)
(CReg StkStubReg))
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgUpdate where
-import AbsCSyn(CAddrMode)
-import CgMonad(CgInfoDownwards, CgState)
-pushUpdateFrame :: CAddrMode -> CAddrMode -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-
\begin{code}
#include "HsVersions.h"
-module CgUpdate (
- pushUpdateFrame -- OLD: , evalPushRCCFrame
- ) where
+module CgUpdate ( pushUpdateFrame ) where
import StgSyn
import CgMonad
pushUpdateFrame updatee vector code
= isSwitchSetC SccProfilingOn `thenFC` \ profiling_on ->
let
- -- frame_size *includes* the return address
+ -- frame_size *includes* the return address
frame_size = if profiling_on
then sCC_STD_UF_SIZE
else sTD_UF_SIZE
pushOnBStack (CReg SuA) `thenFC` \ _ ->
pushOnBStack (CReg SuB) `thenFC` \ _ ->
pushOnBStack updatee `thenFC` \ _ ->
- pushOnBStack (CLabel sTD_UPD_RET_VEC_LABEL CodePtrKind) `thenFC` \ _ ->
+ pushOnBStack (CLabel sTD_UPD_RET_VEC_LABEL CodePtrRep) `thenFC` \ _ ->
-- MAKE SuA, SuB POINT TO TOP OF A,B STACKS
-- Remember, SpB hasn't yet been incremented to account for the
(CAssign (CReg SuB) (CAddr (SpBRel 0 4))))
-------------------------- -}
\end{code}
-
-@evalPushRCCFrame@ pushes a frame to restore the cost centre, and
-deallocates stuff from the A and B stack if evaluation profiling. No
-actual update is required so no closure to update is passed.
-@evalPushRCCFrame@ is called for an @scc@ expression and on entry to a
-single-entry thunk: no update reqd but cost centre manipulation is.
-
-\begin{code}
-{- OLD: WDP: 94/06
-
-evalPushRCCFrame :: Bool -> Code -> Code
-
-evalPushRCCFrame prim code
- = isSwitchSetC SccProfiling_Eval `thenFC` \ eval_profiling ->
-
- if (not eval_profiling) then
- code
- else
-
- -- Find out how many words of stack must will be
- -- deallocated at the end of the basic block
- -- As we push stuff onto the B stack we must make the
- -- RCC frame dealocate the B stack words
-
- -- We dont actually push things onto the A stack so we
- -- can treat the A stack as if these words were not there
- -- i.e. we subtract them from the A stack offset
- -- They will be popped by the current block of code
-
- -- Tell downstream code about the update frame on the B stack
- allocUpdateFrame
- sCC_RCC_UF_SIZE
- (panic "pushEvalRCCFrame: mkRestoreCostCentreLbl")
- (\ (old_args_spa, old_args_spb, upd_frame_offset) ->
-
- getSpARelOffset old_args_spa `thenFC` \ old_args_spa_rel ->
- getSpBRelOffset upd_frame_offset `thenFC` \ upd_frame_rel ->
-
- let b_wds_to_pop = upd_frame_offset - old_args_spb
- in
-
- -- Allocate enough space on the B stack for the frame
-
- evalCostCentreC
- (if prim then
- "PUSH_RCC_FRAME_RETURN"
- else
- "PUSH_RCC_FRAME_VECTOR")
- [
- mkIntCLit (spARelToInt old_args_spa_rel),
- {- Place on A stack to ``draw the line'' -}
- mkIntCLit (spBRelToInt upd_frame_rel),
- {- Ditto B stk. The update frame is pushed starting
- just above here -}
- mkIntCLit 0,
- {- Number of words of A below the line, which must be
- popped to get to the tail-call position -}
- mkIntCLit b_wds_to_pop
- {- Ditto B stk -}
- ] `thenC`
-
- code
-
-
- -- If we actually pushed things onto the A stack we have
- -- to arrange for the RCC frame to pop these as well
- -- Would need to tell downstream code about the update frame
- -- both the A and B stacks
- )
--}
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CgUsages where
-import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import UniqFM(UniqFM)
-data AbstractC
-data RegRelative
-data CgState
-data HeapOffset
-freeBStkSlot :: Int -> CgInfoDownwards -> CgState -> CgState
-getHpRelOffset :: HeapOffset -> CgInfoDownwards -> CgState -> (RegRelative, CgState)
-getSpARelOffset :: Int -> CgInfoDownwards -> CgState -> (RegRelative, CgState)
-getSpBRelOffset :: Int -> CgInfoDownwards -> CgState -> (RegRelative, CgState)
-getVirtAndRealHp :: CgInfoDownwards -> CgState -> ((HeapOffset, HeapOffset), CgState)
-getVirtSps :: CgInfoDownwards -> CgState -> ((Int, Int), CgState)
-initHeapUsage :: (HeapOffset -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
-setRealAndVirtualSps :: Int -> Int -> CgInfoDownwards -> CgState -> CgState
-setRealHp :: HeapOffset -> CgInfoDownwards -> CgState -> CgState
-setVirtHp :: HeapOffset -> CgInfoDownwards -> CgState -> CgState
-
\begin{code}
module CgUsages (
initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp,
- setRealAndVirtualSps,
+ setRealAndVirtualSps,
getVirtSps,
getHpRelOffset, getSpARelOffset, getSpBRelOffset,
---UNUSED: getVirtSpRelOffsets,
freeBStkSlot,
= (SpBRel realSpB virtual_offset, state)
\end{code}
-
-\begin{code}
-{- UNUSED:
-getVirtSpRelOffsets :: FCode (RegRelative, RegRelative)
-getVirtSpRelOffsets info_down
- state@(MkCgState absC binds ((virtSpA,_,realSpA,_), (virtSpB,_,realSpB,_), _))
- = ((SpARel realSpA virtSpA, SpBRel realSpB virtSpB), state)
--}
-\end{code}
-
\begin{code}
freeBStkSlot :: VirtualSpBOffset -> Code
freeBStkSlot b_slot info_down
state@(MkCgState absC binds (spa_usage, (virtSpB,free_b,realSpB,hwSpB), heap_usage))
- = MkCgState absC binds (spa_usage, (virtSpB,new_free_b,realSpB,hwSpB), heap_usage)
- where
- new_free_b = addFreeBSlots free_b [b_slot]
-
+ = MkCgState absC binds (spa_usage, (virtSpB,new_free_b,realSpB,hwSpB), heap_usage)
+ where
+ new_free_b = addFreeBSlots free_b [b_slot]
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ClosureInfo where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CgBindery(CgIdInfo)
-import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, FCode(..), StubFlag)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Id(DataCon(..), Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind, getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, ltSMRepHdr)
-import StgSyn(PlainStgAtom(..), PlainStgExpr(..), PlainStgLiveVars(..), StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgExpr, UpdateFlag(..))
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data AbstractC
-data CAddrMode
-data MagicId
-data CLabel
-data CgIdInfo
-data CgInfoDownwards
-data CgState
-data ClosureInfo
-data CompilationInfo
-data EntryConvention = ViaNode | StdEntry CLabel (Labda CLabel) | DirectEntry CLabel Int [MagicId]
-type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
-data HeapOffset
-type DataCon = Id
-data Id
-data Labda a
-data LambdaFormInfo
-data PrimKind
-data SMRep
-type PlainStgAtom = StgAtom Id
-type PlainStgExpr = StgExpr Id Id
-type PlainStgLiveVars = UniqFM Id
-data StandardFormInfo
-data StgAtom a
-data StgBinderInfo
-data StgExpr a b
-data UpdateFlag = ReEntrant | Updatable | SingleEntry
-data TyCon
-data UniqFM a
-type UniqSet a = UniqFM a
-allocProfilingMsg :: ClosureInfo -> _PackedString
-blackHoleClosureInfo :: ClosureInfo -> ClosureInfo
-blackHoleOnEntry :: Bool -> ClosureInfo -> Bool
-closureGoodStuffSize :: ClosureInfo -> Int
-closureHdrSize :: ClosureInfo -> HeapOffset
-closureId :: ClosureInfo -> Id
-closureKind :: ClosureInfo -> [Char]
-closureLFInfo :: ClosureInfo -> LambdaFormInfo
-closureLabelFromCI :: ClosureInfo -> CLabel
-closureNonHdrSize :: ClosureInfo -> Int
-closurePtrsSize :: ClosureInfo -> Int
-closureReturnsUnboxedType :: ClosureInfo -> Bool
-closureSMRep :: ClosureInfo -> SMRep
-closureSemiTag :: ClosureInfo -> Int
-closureSingleEntry :: ClosureInfo -> Bool
-closureSize :: ClosureInfo -> HeapOffset
-closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset
-closureType :: ClosureInfo -> Labda (TyCon, [UniType], [Id])
-closureTypeDescr :: ClosureInfo -> [Char]
-closureUpdReqd :: ClosureInfo -> Bool
-dataConLiveness :: ((Int -> GlobalSwitch) -> Labda Int) -> ClosureInfo -> Int
-entryLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI :: ClosureInfo -> CLabel
-fitsMinUpdSize :: ClosureInfo -> Bool
-funInfoTableRequired :: Id -> StgBinderInfo -> LambdaFormInfo -> Bool
-getEntryConvention :: Id -> LambdaFormInfo -> [PrimKind] -> CgInfoDownwards -> CgState -> (EntryConvention, CgState)
-getSMInfoStr :: SMRep -> [Char]
-getSMInitHdrStr :: SMRep -> [Char]
-getSMUpdInplaceHdrStr :: SMRep -> [Char]
-getStandardFormThunkInfo :: LambdaFormInfo -> Labda [StgAtom Id]
-infoTableLabelFromCI :: ClosureInfo -> CLabel
-isConstantRep :: SMRep -> Bool
-isPhantomRep :: SMRep -> Bool
-isSpecRep :: SMRep -> Bool
-isStaticClosure :: ClosureInfo -> Bool
-layOutDynClosure :: Id -> (a -> PrimKind) -> [a] -> LambdaFormInfo -> (ClosureInfo, [(a, HeapOffset)])
-layOutDynCon :: Id -> (a -> PrimKind) -> [a] -> (ClosureInfo, [(a, HeapOffset)])
-layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo
-layOutStaticClosure :: Id -> (a -> PrimKind) -> [a] -> LambdaFormInfo -> (ClosureInfo, [(a, HeapOffset)])
-layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo
-ltSMRepHdr :: SMRep -> SMRep -> Bool
-maybeSelectorInfo :: ClosureInfo -> Labda (Id, Int)
-mkClosureLFInfo :: Bool -> [Id] -> UpdateFlag -> [Id] -> StgExpr Id Id -> LambdaFormInfo
-mkConLFInfo :: Id -> LambdaFormInfo
-mkLFArgument :: LambdaFormInfo
-mkLFImported :: Id -> LambdaFormInfo
-mkLFLetNoEscape :: Int -> UniqFM Id -> LambdaFormInfo
-mkVirtHeapOffsets :: SMRep -> (a -> PrimKind) -> [a] -> (Int, Int, [(a, HeapOffset)])
-noUpdVapRequired :: StgBinderInfo -> Bool
-nodeMustPointToIt :: LambdaFormInfo -> CgInfoDownwards -> CgState -> (Bool, CgState)
-slopSize :: ClosureInfo -> Int
-slowFunEntryCodeRequired :: Id -> StgBinderInfo -> Bool
-staticClosureRequired :: Id -> StgBinderInfo -> LambdaFormInfo -> Bool
-stdVapRequired :: StgBinderInfo -> Bool
-
closureSize, closureHdrSize,
closureNonHdrSize, closureSizeWithoutFixedHdr,
- closureGoodStuffSize, closurePtrsSize, -- UNUSED: closureNonPtrsSize,
+ closureGoodStuffSize, closurePtrsSize,
slopSize, fitsMinUpdSize,
layOutDynClosure, layOutDynCon, layOutStaticClosure,
layOutStaticNoFVClosure, layOutPhantomClosure,
- mkVirtHeapOffsets, -- for GHCI
+ mkVirtHeapOffsets, -- for GHCI
nodeMustPointToIt, getEntryConvention,
blackHoleOnEntry,
- staticClosureRequired,
+ staticClosureRequired,
slowFunEntryCodeRequired, funInfoTableRequired,
stdVapRequired, noUpdVapRequired,
closureSingleEntry, closureSemiTag, closureType,
closureReturnsUnboxedType, getStandardFormThunkInfo,
---OLD auxInfoTableLabelFromCI, isIntLikeRep, -- go away in 0.23
-
closureKind, closureTypeDescr, -- profiling
isConstantRep, isSpecRep, isPhantomRep, -- ToDo: Should be in SMRep, perhaps?
isStaticClosure, allocProfilingMsg,
blackHoleClosureInfo,
getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- ltSMRepHdr, --UNUSED: equivSMRepHdr,
+ ltSMRepHdr,
maybeSelectorInfo,
- dataConLiveness, -- concurrency
+ dataConLiveness -- concurrency
-- and to make the interface self-sufficient...
- AbstractC, CAddrMode, HeapOffset, MagicId,
- CgInfoDownwards, CgState, CgIdInfo, CompilationInfo,
- CLabel, Id, Maybe, PrimKind, FCode(..), TyCon, StgExpr,
- StgAtom, StgBinderInfo,
- DataCon(..), PlainStgExpr(..), PlainStgLiveVars(..),
- PlainStgAtom(..),
- UniqSet(..), UniqFM, UpdateFlag(..) -- not abstract
-
- IF_ATTACK_PRAGMAS(COMMA mkClosureLabel)
- IF_ATTACK_PRAGMAS(COMMA getUniDataSpecTyCon_maybe)
) where
import AbsCSyn
import SMRep
import StgSyn
-import AbsUniType
+import Type
import CgCompInfo -- some magic constants
import CgRetConv
-import CLabelInfo -- Lots of label-making things
+import CLabel -- Lots of label-making things
import CmdLineOpts ( GlobalSwitch(..) )
import Id
import IdInfo -- SIGH
import Maybes ( maybeToBool, assocMaybe, Maybe(..) )
import Outputable -- needed for INCLUDE_FRC_METHOD
import Pretty -- ( ppStr, Pretty(..) )
-import PrimKind ( PrimKind, getKindSize, separateByPtrFollowness )
+import PrimRep ( PrimRep, getPrimRepSize, separateByPtrFollowness )
import Util
\end{code}
| LFTuple -- Tuples
DataCon -- The tuple constructor (may be specialised)
Bool -- True <=> zero arity
-
+
| LFThunk -- Thunk (zero arity)
Bool -- True <=> top level
Bool -- True <=> no free vars
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
Int -- arity;
- PlainStgLiveVars-- list of variables live in the RHS of the let.
+ StgLiveVars-- list of variables live in the RHS of the let.
-- (ToDo: maybe not used)
| LFBlackHole -- Used for the closures allocated to hold the result
= NonStandardThunk -- No, it isn't
- | SelectorThunk
+ | SelectorThunk
Id -- Scrutinee
DataCon -- Constructor
Int -- 0-origin offset of ak within the "goods" of constructor
-- (Recall that the a1,...,an may be laid out in the heap
-- in a non-obvious order.)
-
+
{- A SelectorThunk is of form
- case x of
- con a1,..,an -> ak
-
- and the constructor is from a single-constr type.
+ case x of
+ con a1,..,an -> ak
+
+ and the constructor is from a single-constr type.
If we can't convert the heap-offset of the selectee into an Int, e.g.,
it's "GEN_VHS+i", we just give up.
-}
-
+
| VapThunk
Id -- Function
- [PlainStgAtom] -- Args
- Bool -- True <=> the function is not top-level, so
+ [StgArg] -- Args
+ Bool -- True <=> the function is not top-level, so
-- must be stored in the thunk too
-
+
{- A VapThunk is of form
- f a1 ... an
+ f a1 ... an
- where f is a known function, with arity n
- So for this thunk we can use the label for f's heap-entry
- info table (generated when f's defn was dealt with),
- rather than generating a one-off info table and entry code
- for this one thunk.
+ where f is a known function, with arity n
+ So for this thunk we can use the label for f's heap-entry
+ info table (generated when f's defn was dealt with),
+ rather than generating a one-off info table and entry code
+ for this one thunk.
-}
-
+
mkLFArgument = LFArgument
mkLFBlackHole = LFBlackHole
mkLFLetNoEscape = LFLetNoEscape
-> [Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
- -> PlainStgExpr -- Body of closure: passed so we
+ -> StgExpr -- Body of closure: passed so we
-- can look for selector thunks!
-> LambdaFormInfo
[the_fv] -- just one...
Updatable
[] -- no args (a thunk)
- (StgCase (StgApp (StgVarAtom scrutinee) [{-no args-}] _)
+ (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
_ _ _ -- ignore live vars and uniq...
(StgAlgAlts case_ty
[(con, params, use_mask,
- (StgApp (StgVarAtom selectee) [{-no args-}] _))]
+ (StgApp (StgVarArg selectee) [{-no args-}] _))]
StgNoDefault))
| the_fv == scrutinee -- Scrutinee is the only free variable
&& maybeToBool maybe_offset -- Selectee is a component of the tuple
&& maybeToBool offset_into_int_maybe
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
- =
+ =
-- ASSERT(is_single_constructor) -- Should be true, by causes error for SpecTyCon
LFThunk False False True (SelectorThunk scrutinee con offset_into_int)
where
- (_, params_w_offsets) = layOutDynCon con getIdKind params
+ (_, params_w_offsets) = layOutDynCon con getIdPrimRep params
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
- offset_into_int_maybe = intOffsetIntoGoods the_offset
+ offset_into_int_maybe = intOffsetIntoGoods the_offset
Just offset_into_int = offset_into_int_maybe
is_single_constructor = maybeToBool (maybeSingleConstructorTyCon tycon)
(_,_,_, tycon) = getDataConSig con
fvs
upd_flag
[] -- No args; a thunk
- (StgApp (StgVarAtom fun_id) args _)
- | not top_level -- A top-level thunk would require a static
+ (StgApp (StgVarArg fun_id) args _)
+ | not top_level -- A top-level thunk would require a static
-- vap_info table, which we don't generate just
-- now; so top-level thunks are never standard
-- form.
@ConstantRep@ and @CharLikeRep@ closures always use the address of
a static closure. They are never allocated or
collected (eg hold forwarding pointer) hence never any slop.
-
+
\item
@IntLikeRep@ are never updatable.
May need slop to be collected (as they will be size 1 or more
\begin{code}
layOutDynClosure, layOutStaticClosure
:: Id -- STG identifier w/ which this closure assoc'd
- -> (a -> PrimKind) -- function w/ which to be able to get a PrimKind
+ -> (a -> PrimRep) -- function w/ which to be able to get a PrimRep
-> [a] -- the "things" being layed out
-> LambdaFormInfo -- what sort of closure it is
-> (ClosureInfo, -- info about the closure
A wrapper for when used with data constructors:
\begin{code}
layOutDynCon :: DataCon
- -> (a -> PrimKind)
+ -> (a -> PrimRep)
-> [a]
-> (ClosureInfo, [(a,VirtualHeapOffset)])
-layOutDynCon con kind_fn args
+layOutDynCon con kind_fn args
= ASSERT(isDataCon con)
layOutDynClosure con kind_fn args (mkConLFInfo con)
\end{code}
\begin{code}
mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
- -> (a -> PrimKind) -- To be able to grab kinds;
+ -> (a -> PrimRep) -- To be able to grab kinds;
-- w/ a kind, we can find boxedness
-> [a] -- Things to make offsets for
-> (Int, -- *Total* number of words allocated
where
offset_of_first_word = totHdrSize sm_rep
computeOffset wds_so_far thing
- = (wds_so_far + (getKindSize . kind_fun) thing,
+ = (wds_so_far + (getPrimRepSize . kind_fun) thing,
(thing, (offset_of_first_word `addOff` (intOff wds_so_far)))
)
\end{code}
-- is not top level as special case cgRhsClosure
-- has been dissabled in favour of let floating
---OLD: || (arity == 0 && do_profiling)
--- -- Access to cost centre required for 0 arity if profiling
--- -- Simon: WHY? (94/12)
-
-- For lex_profiling we also access the cost centre for a
-- non-inherited function i.e. not top level
-- the not top case above ensures this is ok.
0 arg, fvs @\u@ & yes & yes & n/a & node\\
\end{tabular}
-When black-holing, single-entry closures could also be entered via node
+When black-holing, single-entry closures could also be entered via node
(rather than directly) to catch double-entry.
\begin{code}
= ViaNode -- The "normal" convention
| StdEntry CLabel -- Jump to this code, with args on stack
- (Maybe CLabel) -- possibly setting infoptr to this
+ (Maybe CLabel) -- possibly setting infoptr to this
| DirectEntry -- Jump directly to code, with args in regs
CLabel -- The code label
getEntryConvention :: Id -- Function being applied
-> LambdaFormInfo -- Its info
- -> [PrimKind] -- Available arguments
+ -> [PrimRep] -- Available arguments
-> FCode EntryConvention
getEntryConvention id lf_info arg_kinds
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
+ isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
getIntSwitchChkrC `thenFC` \ isw_chkr ->
returnFC (
case lf_info of
- LFReEntrant _ arity _ ->
- if arity == 0 || (length arg_kinds) < arity then
+ LFReEntrant _ arity _ ->
+ if arity == 0 || (length arg_kinds) < arity then
StdEntry (mkStdEntryLabel id) Nothing
- else
+ else
DirectEntry (mkFastEntryLabel id arity) arity arg_regs
where
(arg_regs, _) = assignRegs isw_chkr live_regs (take arity arg_kinds)
live_regs = if node_points then [node] else []
- LFCon con zero_arity
- -> let itbl = if zero_arity then
+ LFCon con zero_arity
+ -> let itbl = if zero_arity then
mkPhantomInfoTableLabel con
else
mkInfoTableLabel con
in StdEntry (mkStdEntryLabel con) (Just itbl)
-- Should have no args
- LFTuple tup zero_arity
+ LFTuple tup zero_arity
-> StdEntry (mkStdEntryLabel tup)
(Just (mkInfoTableLabel tup))
-- Should have no args
then ViaNode
else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing
- LFArgument -> ViaNode
- LFImported -> ViaNode
- LFBlackHole -> ViaNode -- Presumably the black hole has by now
+ LFArgument -> ViaNode
+ LFImported -> ViaNode
+ LFBlackHole -> ViaNode -- Presumably the black hole has by now
-- been updated, but we don't know with
-- what, so we enter via Node
-> if updatable
then not no_black_holing
else not no_fvs
- other -> panic "blackHoleOnEntry" -- Should never happen
+ other -> panic "blackHoleOnEntry" -- Should never happen
-getStandardFormThunkInfo
- :: LambdaFormInfo
- -> Maybe [PlainStgAtom] -- Nothing => not a standard-form thunk
+getStandardFormThunkInfo
+ :: LambdaFormInfo
+ -> Maybe [StgArg] -- Nothing => not a standard-form thunk
-- Just atoms => a standard-form thunk with payload atoms
getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _))
= --trace "Selector thunk: missed opportunity to save info table + code"
Nothing
- -- Just [StgVarAtom scrutinee]
+ -- Just [StgVarArg scrutinee]
-- We can't save the info tbl + code until we have a way to generate
-- a fixed family thereof.
getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload))
- | fun_in_payload = Just (StgVarAtom fun_id : args)
+ | fun_in_payload = Just (StgVarArg fun_id : args)
| otherwise = Just args
getStandardFormThunkInfo other_lf_info = Nothing
OR (b) the function is passed as an arg
OR (c) if the function has free vars (ie not top level)
- Why case (a) here? Because if the arg-satis check fails,
+ Why case (a) here? Because if the arg-satis check fails,
UpdatePAP stuffs a pointer to the function closure in the PAP.
[Could be changed; UpdatePAP could stuff in a code ptr instead,
but doesn't seem worth it.]
- [NB: these conditions imply that we might need the closure
+ [NB: these conditions imply that we might need the closure
without the slow-entry code. Here's how.
f x y = let g w = ...x..y..w...
Needed iff (a) we have any un-saturated calls to the function
OR (b) the function is passed as an arg
OR (c) the function has free vars (ie not top level)
-
+
NB. In the sequential world, (c) is only required so that the function closure has
an info table to point to, to keep the storage manager happy.
If (c) alone is true we could fake up an info table by choosing
* Single-update vap-entry code
Single-update vap-entry info table
- Needed iff we have any non-updatable thunks of the
+ Needed iff we have any non-updatable thunks of the
standard vap-entry shape.
-
+
\begin{code}
staticClosureRequired
:: Id
- -> StgBinderInfo
+ -> StgBinderInfo
-> LambdaFormInfo
-> Bool
-staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
+staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
(LFReEntrant top_level _ _) -- It's a function
= ASSERT( top_level ) -- Assumption: it's a top-level, no-free-var binding
arg_occ -- There's an argument occurrence
-> LambdaFormInfo
-> Bool
funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- (LFReEntrant top_level _ _)
+ (LFReEntrant top_level _ _)
= not top_level
|| arg_occ -- There's an argument occurrence
|| unsat_occ -- There's an unsaturated call
funInfoTableRequired other_binder_info binder other_lf_info = True
--- We need the vector-apply entry points for a function if
--- there's a vector-apply occurrence in this module
+-- We need the vector-apply entry points for a function if
+-- there's a vector-apply occurrence in this module
stdVapRequired, noUpdVapRequired :: StgBinderInfo -> Bool
Note: @closureType@ returns appropriately specialised tycon and
datacons.
\begin{code}
-closureType :: ClosureInfo -> Maybe (TyCon, [UniType], [Id])
+closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
-- First, a turgid special case. When we are generating the
-- standard code and info-table for Vaps (which is done when the function
closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
= getUniDataSpecTyCon_maybe (funResultTy de_foralld_ty (length args))
where
- (_, de_foralld_ty) = splitForalls (getIdUniType fun_id)
+ (_, de_foralld_ty) = splitForalls (idType fun_id)
-closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (getIdUniType id)
+closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (idType id)
\end{code}
@closureReturnsUnboxedType@ is used to check whether a closure, {\em
closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
= isPrimType (funResultTy de_foralld_ty arity)
where
- (_, de_foralld_ty) = splitForalls (getIdUniType fun_id)
+ (_, de_foralld_ty) = splitForalls (idType fun_id)
closureReturnsUnboxedType other_closure = False
-- All non-function closures aren't functions,
= case lf_info of
LFCon data_con _ -> getDataConTag data_con - fIRST_TAG
LFTuple _ _ -> 0
- --UNUSED: LFIndirection -> fromInteger iND_TAG
_ -> fromInteger oTHER_TAG
\end{code}
LFBlackHole -> mkBlackHoleInfoTableLabel
LFThunk _ _ upd_flag (VapThunk fun_id args _) -> mkVapInfoTableLabel fun_id upd_flag
- -- Use the standard vap info table
+ -- Use the standard vap info table
-- for the function, rather than a one-off one
-- for this particular closure
else -} mkInfoTableLabel id
mkConInfoPtr :: Id -> SMRep -> CLabel
-mkConInfoPtr id rep =
- case rep of
+mkConInfoPtr id rep =
+ case rep of
PhantomRep -> mkPhantomInfoTableLabel id
StaticRep _ _ -> mkStaticInfoTableLabel id
_ -> mkInfoTableLabel id
mkConEntryPtr :: Id -> SMRep -> CLabel
-mkConEntryPtr id rep =
- case rep of
+mkConEntryPtr id rep =
+ case rep of
StaticRep _ _ -> mkStaticConEntryLabel id
_ -> mkConEntryLabel id
-- I don't think it needs to deal with the SelectorThunk case
-- Well, it's falling over now, so I've made it deal with it. (JSM)
-thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
+thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
= mkVapEntryLabel fun_id is_updatable
-thunkEntryLabel thunk_id _ is_updatable
+thunkEntryLabel thunk_id _ is_updatable
= mkStdEntryLabel thunk_id
-
+
fastLabelFromCI :: ClosureInfo -> CLabel
fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity
where
LFTuple _ _ -> SLIT("ALLOC_CON")
LFThunk _ _ _ _ -> SLIT("ALLOC_THK")
LFBlackHole -> SLIT("ALLOC_BH")
- --UNUSED: LFIndirection -> panic "ALLOC_IND"
LFImported -> panic "ALLOC_IMP"
\end{code}
LFTuple _ _ -> "CON_K"
LFThunk _ _ _ _ -> "THK_K"
LFBlackHole -> "THK_K" -- consider BHs as thunks for the moment... (ToDo?)
- --UNUSED: LFIndirection -> panic "IND_KIND"
LFImported -> panic "IMP_KIND"
closureTypeDescr :: ClosureInfo -> String
= if (isDataCon id) then -- DataCon has function types
_UNPK_ (getOccurrenceName (getDataConTyCon id)) -- We want the TyCon not the ->
else
- getUniTyDescription (getIdUniType id)
+ getUniTyDescription (idType id)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CodeGen where
-import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import ClosureInfo(ClosureInfo)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CostCentre(CostCentre)
-import FiniteMap(FiniteMap)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import StgSyn(StgBinding, StgRhs)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data AbstractC
-data FiniteMap a b
-data Id
-data StgBinding a b
-data UniqFM a
-codeGen :: _PackedString -> ([CostCentre], [CostCentre]) -> [_PackedString] -> (GlobalSwitch -> SwitchResult) -> [TyCon] -> FiniteMap TyCon [(Bool, [Labda UniType])] -> [StgBinding Id Id] -> AbstractC
-
\begin{code}
#include "HsVersions.h"
-module CodeGen (
- codeGen,
-
- -- and to make the interface self-sufficient...
- UniqFM, AbstractC, StgBinding, Id, FiniteMap
- ) where
-
+module CodeGen ( codeGen ) where
import StgSyn
import CgMonad
import AbsCSyn
-import CLabelInfo ( modnameToC )
+import CLabel ( modnameToC )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon )
import CgConTbls ( genStaticConBits, TCE(..), UniqFM )
import FiniteMap ( FiniteMap )
import Maybes ( Maybe(..) )
import Pretty -- debugging only
-import PrimKind ( getKindSize )
+import PrimRep ( getPrimRepSize )
import Util
\end{code}
-> ([CostCentre], -- local cost-centres needing declaring/registering
[CostCentre]) -- "extern" cost-centres needing declaring
-> [FAST_STRING] -- import names
- -> (GlobalSwitch -> SwitchResult)
- -- global switch lookup function
-> [TyCon] -- tycons with data constructors to convert
- -> FiniteMap TyCon [(Bool, [Maybe UniType])]
+ -> FiniteMap TyCon [(Bool, [Maybe Type])]
-- tycon specialisation info
- -> PlainStgProgram -- bindings to convert
+ -> [StgBinding] -- bindings to convert
-> AbstractC -- output
-codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons tycon_specs stg_pgm
+codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg_pgm
= let
- switch_is_on = switchIsOn sw_lookup_fn
- int_switch_set = intSwitchSet sw_lookup_fn
- doing_profiling = switch_is_on SccProfilingOn
- compiling_prelude = switch_is_on CompilingPrelude
+ doing_profiling = opt_SccProfilingOn
+ compiling_prelude = opt_CompilingPrelude
maybe_split = if (switch_is_on (EnsureSplittableC (panic "codeGen:esc")))
then CSplitMarker
else AbsCNop
cinfo = MkCompInfo switch_is_on int_switch_set mod_name
in
-
-{- OLD:
- pprTrace "codeGen:" (ppCat [
- (case (switch_is_on StgDoLetNoEscapes) of
- False -> ppStr "False?"
- True -> ppStr "True?"
- ),
- (case (int_switch_set ReturnInRegsThreshold) of
- Nothing -> ppStr "Nothing!"
- Just n -> ppCat [ppStr "Just", ppInt n]
- ),
- (case (int_switch_set UnfoldingUseThreshold) of
- Nothing -> ppStr "Nothing!"
- Just n -> ppCat [ppStr "Just", ppInt n]
- ),
- (case (int_switch_set UnfoldingCreationThreshold) of
- Nothing -> ppStr "Nothing!"
- Just n -> ppCat [ppStr "Just", ppInt n]
- )
- ]) $
--}
if not doing_profiling then
mkAbstractCs [
genStaticConBits cinfo gen_tycons tycon_specs,
-----------------
mkCcRegister ccs import_names
- = let
+ = let
register_ccs = mkAbstractCs (map mk_register ccs)
register_imports = mkAbstractCs (map mk_import_register import_names)
in
mkAbstractCs [
- CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrKind],
+ CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep],
register_ccs,
register_imports,
CCallProfCCMacro SLIT("END_REGISTER_CCS") []
= CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
mk_import_register import_name
- = CCallProfCCMacro SLIT("REGISTER_IMPORT") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrKind]
+ = CCallProfCCMacro SLIT("REGISTER_IMPORT") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrRep]
\end{code}
%************************************************************************
variable.
\begin{code}
-cgTopBindings :: AbstractC -> PlainStgProgram -> Code
+cgTopBindings :: AbstractC -> [StgBinding] -> Code
cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
-
-cgTopBinding :: AbstractC -> PlainStgBinding -> Code
-cgTopBinding split (StgNonRec name rhs)
+cgTopBinding :: AbstractC -> StgBinding -> Code
+
+cgTopBinding split (StgNonRec name rhs)
= absC split `thenC`
cgTopRhs name rhs `thenFC` \ (name, info) ->
addBindC name info
-cgTopBinding split (StgRec pairs)
+cgTopBinding split (StgRec pairs)
= absC split `thenC`
fixC (\ new_binds -> addBindsC new_binds `thenC`
mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
-- to enclose the listFCs in cgTopBinding, but that tickled the
-- statics "error" call in initC. I DON'T UNDERSTAND WHY!
-cgTopRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo)
+cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along for setting up a binding...
cgTopRhs name (StgRhsCon cc con args)
= forkStatics (cgTopRhsCon name con args (all zero_size args))
where
- zero_size atom = getKindSize (getAtomKind atom) == 0
+ zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
cgTopRhs name (StgRhsClosure cc bi fvs upd_flag args body)
= ASSERT(null fvs) -- There should be no free variables
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SMRep where
-import Outputable(Outputable)
-data SMRep = StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int
-data SMSpecRepKind = SpecRep | ConstantRep | CharLikeRep | IntLikeRep
-data SMUpdateKind = SMNormalForm | SMSingleEntry | SMUpdatable
-getSMInfoStr :: SMRep -> [Char]
-getSMInitHdrStr :: SMRep -> [Char]
-getSMUpdInplaceHdrStr :: SMRep -> [Char]
-ltSMRepHdr :: SMRep -> SMRep -> Bool
-instance Eq SMRep
-instance Ord SMRep
-instance Outputable SMRep
-instance Text SMRep
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[SMRep]{Storage manager representations of closure}
module SMRep (
SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- ltSMRepHdr -- UNUSED, equivSMRepHdr
+ ltSMRepHdr
) where
-import Outputable
-import Pretty
-import Util
+import Ubiq{-uitous-}
+
+import Pretty ( ppStr )
+import Util ( panic )
\end{code}
%************************************************************************
SMSpecRepKind -- Which kind of specialised representation
Int -- # ptr words
Int -- # non-ptr words
- SMUpdateKind -- Updatable?
+ SMUpdateKind -- Updatable?
| GenericRep -- GC routines consult sizes in info tbl
Int -- # ptr words
Int -- # non-ptr words
- SMUpdateKind -- Updatable?
+ SMUpdateKind -- Updatable?
| BigTupleRep -- All ptrs, size in var-hdr field
-- Used for big tuples
Never generated by the compiler, and only used in the RTS when
mutuples don't require special attention at GC time (e.g. 2s)
When it is used, it is a primitive object (never entered).
- May be mutable...probably should never be used in the parallel
+ May be mutable...probably should never be used in the parallel
system, since we need to distinguish mutables from immutables when
deciding whether to copy or move closures across processors.
(DataRep a1) == (DataRep a2) = a1 == a2
a == b = (tagOf_SMRep a) _EQ_ (tagOf_SMRep b)
-{- UNUSED:
-equivSMRepHdr :: SMRep -> SMRep -> Bool
-a `equivSMRepHdr` b = (tagOf_SMRep a) _EQ_ (tagOf_SMRep b)
--}
-
ltSMRepHdr :: SMRep -> SMRep -> Bool
a `ltSMRepHdr` b = (tagOf_SMRep a) _LT_ (tagOf_SMRep b)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AnnCoreSyn where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import Outputable(NamedThing, Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-data AnnCoreBinding a b c = AnnCoNonRec a (c, AnnCoreExpr' a b c) | AnnCoRec [(a, (c, AnnCoreExpr' a b c))]
-data AnnCoreCaseAlternatives a b c = AnnCoAlgAlts [(Id, [a], (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c) | AnnCoPrimAlts [(BasicLit, (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c)
-data AnnCoreCaseDefault a b c = AnnCoNoDefault | AnnCoBindDefault a (c, AnnCoreExpr' a b c)
-type AnnCoreExpr a b c = (c, AnnCoreExpr' a b c)
-data AnnCoreExpr' a b c = AnnCoVar b | AnnCoLit BasicLit | AnnCoCon Id [UniType] [CoreAtom b] | AnnCoPrim PrimOp [UniType] [CoreAtom b] | AnnCoLam [a] (c, AnnCoreExpr' a b c) | AnnCoTyLam TyVar (c, AnnCoreExpr' a b c) | AnnCoApp (c, AnnCoreExpr' a b c) (CoreAtom b) | AnnCoTyApp (c, AnnCoreExpr' a b c) UniType | AnnCoCase (c, AnnCoreExpr' a b c) (AnnCoreCaseAlternatives a b c) | AnnCoLet (AnnCoreBinding a b c) (c, AnnCoreExpr' a b c) | AnnCoSCC CostCentre (c, AnnCoreExpr' a b c)
-data BasicLit
-data CostCentre
-data Id
-data PrimOp
-data TyCon
-data TyVar
-data UniType
-deAnnotate :: (a, AnnCoreExpr' b c a) -> CoreExpr b c
-instance Eq BasicLit
-instance Eq PrimOp
-instance Eq TyCon
-instance Eq TyVar
-instance Eq UniType
-instance Ord BasicLit
-instance Ord TyCon
-instance Ord TyVar
-instance NamedThing TyCon
-instance NamedThing TyVar
-instance Outputable BasicLit
-instance Outputable PrimOp
-instance Outputable TyCon
-instance Outputable TyVar
-instance Outputable UniType
-
module AnnCoreSyn (
AnnCoreBinding(..), AnnCoreExpr(..),
AnnCoreExpr'(..), -- v sad that this must be exported
- AnnCoreCaseAlternatives(..), AnnCoreCaseDefault(..),
-#ifdef DPH
- AnnCoreParQuals(..),
- AnnCoreParCommunicate(..),
-#endif {- Data Parallel Haskell -}
+ AnnCoreCaseAlts(..), AnnCoreCaseDefault(..),
- deAnnotate, -- we may eventually export some of the other deAnners
+ deAnnotate -- we may eventually export some of the other deAnners
-- and to make the interface self-sufficient
- BasicLit, Id, PrimOp, TyCon, TyVar, UniType, CostCentre
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
) where
-import AbsPrel ( PrimOp(..), PrimKind
+import PrelInfo ( PrimOp(..), PrimRep
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( Id, TyVar, TyCon, UniType
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import BasicLit ( BasicLit )
+import Literal ( Literal )
import CoreSyn
import Outputable
import CostCentre ( CostCentre )
data AnnCoreExpr' binder bindee annot
= AnnCoVar bindee
- | AnnCoLit BasicLit
+ | AnnCoLit Literal
- | AnnCoCon Id [UniType] [CoreAtom bindee]
+ | AnnCoCon Id [Type] [GenCoreAtom bindee]
- | AnnCoPrim PrimOp [UniType] [CoreAtom bindee]
+ | AnnCoPrim PrimOp [Type] [GenCoreAtom bindee]
- | AnnCoLam [binder]
+ | AnnCoLam binder
(AnnCoreExpr binder bindee annot)
| AnnCoTyLam TyVar
(AnnCoreExpr binder bindee annot)
| AnnCoApp (AnnCoreExpr binder bindee annot)
- (CoreAtom bindee)
+ (GenCoreAtom bindee)
| AnnCoTyApp (AnnCoreExpr binder bindee annot)
- UniType
+ Type
| AnnCoCase (AnnCoreExpr binder bindee annot)
- (AnnCoreCaseAlternatives binder bindee annot)
+ (AnnCoreCaseAlts binder bindee annot)
| AnnCoLet (AnnCoreBinding binder bindee annot)
(AnnCoreExpr binder bindee annot)
| AnnCoSCC CostCentre
(AnnCoreExpr binder bindee annot)
-#ifdef DPH
- | AnnCoZfExpr (AnnCoreExpr binder bindee annot)
- (AnnCoreParQuals binder bindee annot)
-
- | AnnCoParCon Id Int [UniType] [AnnCoreExpr binder bindee annot]
-
- | AnnCoParComm
- Int
- (AnnCoreExpr binder bindee annot)
- (AnnCoreParCommunicate binder bindee annot)
- | AnnCoParZipWith
- Int
- (AnnCoreExpr binder bindee annot)
- [AnnCoreExpr binder bindee annot]
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DPH
-data AnnCoreParQuals binder bindee annot
- = AnnCoAndQuals (AnnCoreParQuals binder bindee annot)
- (AnnCoreParQuals binder bindee annot)
- | AnnCoParFilter (AnnCoreExpr binder bindee annot)
- | AnnCoDrawnGen [binder]
- (binder)
- (AnnCoreExpr binder bindee annot)
- | AnnCoIndexGen [AnnCoreExpr binder bindee annot]
- (binder)
- (AnnCoreExpr binder bindee annot)
-#endif {- Data Parallel Haskell -}
\end{code}
\begin{code}
-data AnnCoreCaseAlternatives binder bindee annot
+data AnnCoreCaseAlts binder bindee annot
= AnnCoAlgAlts [(Id,
[binder],
AnnCoreExpr binder bindee annot)]
(AnnCoreCaseDefault binder bindee annot)
- | AnnCoPrimAlts [(BasicLit,
+ | AnnCoPrimAlts [(Literal,
AnnCoreExpr binder bindee annot)]
(AnnCoreCaseDefault binder bindee annot)
-#ifdef DPH
- | AnnCoParAlgAlts TyCon
- Int
- [binder]
- [(Id,
- AnnCoreExpr binder bindee annot)]
- (AnnCoreCaseDefault binder bindee annot)
- | AnnCoParPrimAlts TyCon
- Int
- [(BasicLit,
- AnnCoreExpr binder bindee annot)]
- (AnnCoreCaseDefault binder bindee annot)
-#endif {- Data Parallel Haskell -}
data AnnCoreCaseDefault binder bindee annot
= AnnCoNoDefault
\end{code}
\begin{code}
-#ifdef DPH
-data AnnCoreParCommunicate binder bindee annot
- = AnnCoParSend [AnnCoreExpr binder bindee annot]
- | AnnCoParFetch [AnnCoreExpr binder bindee annot]
- | AnnCoToPodized
- | AnnCoFromPodized
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-deAnnotate :: AnnCoreExpr bndr bdee ann -> CoreExpr bndr bdee
+deAnnotate :: AnnCoreExpr bndr bdee ann -> GenCoreExpr bndr bdee
-deAnnotate (_, AnnCoVar v) = CoVar v
-deAnnotate (_, AnnCoLit lit) = CoLit lit
-deAnnotate (_, AnnCoCon con tys args) = CoCon con tys args
-deAnnotate (_, AnnCoPrim op tys args) = CoPrim op tys args
-deAnnotate (_, AnnCoLam binders body) = CoLam binders (deAnnotate body)
+deAnnotate (_, AnnCoVar v) = Var v
+deAnnotate (_, AnnCoLit lit) = Lit lit
+deAnnotate (_, AnnCoCon con tys args) = Con con tys args
+deAnnotate (_, AnnCoPrim op tys args) = Prim op tys args
+deAnnotate (_, AnnCoLam binder body) = Lam binder (deAnnotate body)
deAnnotate (_, AnnCoTyLam tyvar body) = CoTyLam tyvar (deAnnotate body)
-deAnnotate (_, AnnCoApp fun arg) = CoApp (deAnnotate fun) arg
+deAnnotate (_, AnnCoApp fun arg) = App (deAnnotate fun) arg
deAnnotate (_, AnnCoTyApp fun ty) = CoTyApp (deAnnotate fun) ty
-deAnnotate (_, AnnCoSCC lbl body) = CoSCC lbl (deAnnotate body)
+deAnnotate (_, AnnCoSCC lbl body) = SCC lbl (deAnnotate body)
deAnnotate (_, AnnCoLet bind body)
- = CoLet (deAnnBind bind) (deAnnotate body)
+ = Let (deAnnBind bind) (deAnnotate body)
where
- deAnnBind (AnnCoNonRec var rhs) = CoNonRec var (deAnnotate rhs)
- deAnnBind (AnnCoRec pairs) = CoRec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
+ deAnnBind (AnnCoNonRec var rhs) = NonRec var (deAnnotate rhs)
+ deAnnBind (AnnCoRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
deAnnotate (_, AnnCoCase scrut alts)
- = CoCase (deAnnotate scrut) (deAnnAlts alts)
+ = Case (deAnnotate scrut) (deAnnAlts alts)
where
- deAnnAlts (AnnCoAlgAlts alts deflt)
- = CoAlgAlts [(con,args,deAnnotate rhs) | (con,args,rhs) <- alts]
+ deAnnAlts (AnnCoAlgAlts alts deflt)
+ = AlgAlts [(con,args,deAnnotate rhs) | (con,args,rhs) <- alts]
(deAnnDeflt deflt)
- deAnnAlts (AnnCoPrimAlts alts deflt)
- = CoPrimAlts [(lit,deAnnotate rhs) | (lit,rhs) <- alts]
+ deAnnAlts (AnnCoPrimAlts alts deflt)
+ = PrimAlts [(lit,deAnnotate rhs) | (lit,rhs) <- alts]
(deAnnDeflt deflt)
- deAnnDeflt AnnCoNoDefault = CoNoDefault
- deAnnDeflt (AnnCoBindDefault var rhs) = CoBindDefault var (deAnnotate rhs)
+ deAnnDeflt AnnCoNoDefault = NoDefault
+ deAnnDeflt (AnnCoBindDefault var rhs) = BindDefault var (deAnnotate rhs)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreFuns where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import Maybes(Labda)
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import TyVarEnv(TyVarEnv(..))
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(UniqSM(..), Unique, UniqueSupply)
-data CoreAtom a
-data CoreExpr a b
-data Id
-type IdEnv a = UniqFM a
-data Labda a
-type TyVarEnv a = UniqFM a
-data UniType
-data UniqFM a
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique
-data UniqueSupply
-atomToExpr :: CoreAtom b -> CoreExpr a b
-bindersOf :: CoreBinding b a -> [b]
-coreExprArity :: (Id -> Labda (CoreExpr a Id)) -> CoreExpr a Id -> Int
-digForLambdas :: CoreExpr a b -> ([TyVar], [a], CoreExpr a b)
-escErrorMsg :: [Char] -> [Char]
-exprSmallEnoughToDup :: CoreExpr a Id -> Bool
-instCoreBindings :: UniqueSupply -> [CoreBinding Id Id] -> (UniqueSupply, [CoreBinding Id Id])
-instCoreExpr :: UniqueSupply -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
-isWrapperFor :: CoreExpr Id Id -> Id -> Bool
-manifestlyBottom :: CoreExpr a Id -> Bool
-manifestlyWHNF :: CoreExpr a Id -> Bool
-maybeErrorApp :: CoreExpr a Id -> Labda UniType -> Labda (CoreExpr a Id)
-mkCoApps :: CoreExpr Id Id -> [CoreExpr Id Id] -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
-mkCoLam :: [a] -> CoreExpr a b -> CoreExpr a b
-mkCoLetAny :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetNoUnboxed :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetUnboxedToCase :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetrecAny :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetrecNoUnboxed :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsAny :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsNoUnboxed :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsUnboxedToCase :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoTyApps :: CoreExpr a b -> [UniType] -> CoreExpr a b
-mkCoTyLam :: [TyVar] -> CoreExpr a b -> CoreExpr a b
-mkCoreIfThenElse :: CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id
-mkErrorCoApp :: UniType -> Id -> [Char] -> CoreExpr Id Id
-mkFunction :: [TyVar] -> [a] -> CoreExpr a b -> CoreExpr a b
-nonErrorRHSs :: CoreCaseAlternatives a Id -> [CoreExpr a Id]
-pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
-squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
-substCoreExpr :: UniqueSupply -> UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
-substCoreExprUS :: UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
-typeOfCoreAlts :: CoreCaseAlternatives Id Id -> UniType
-typeOfCoreExpr :: CoreExpr Id Id -> UniType
-unTagBinders :: CoreExpr (Id, a) b -> CoreExpr Id b
-unTagBindersAlts :: CoreCaseAlternatives (Id, a) b -> CoreCaseAlternatives Id b
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[CoreUtils]{Utility functions}
-
-These functions are re-exported by the various parameterisations of
-@CoreSyn@.
-
-\begin{code}
-#include "HsVersions.h"
-
-module CoreFuns (
- typeOfCoreExpr, typeOfCoreAlts,
-
- instCoreExpr, substCoreExpr, -- UNUSED: cloneCoreExpr,
- substCoreExprUS, -- UNUSED: instCoreExprUS, cloneCoreExprUS,
-
- instCoreBindings,
-
- bindersOf,
-
- mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
- mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
- mkCoLetrecAny, mkCoLetrecNoUnboxed,
- mkCoLam, mkCoreIfThenElse,
--- mkCoApp, mkCoCon, mkCoPrim, -- no need to export
- mkCoApps,
- mkCoTyLam, mkCoTyApps,
- mkErrorCoApp, escErrorMsg,
- pairsFromCoreBinds,
- mkFunction, atomToExpr,
- digForLambdas,
- exprSmallEnoughToDup,
- manifestlyWHNF, manifestlyBottom, --UNUSED: manifestWHNFArgs,
- coreExprArity,
- isWrapperFor,
- maybeErrorApp,
---UNUSED: boilsDownToConApp,
- nonErrorRHSs,
- squashableDictishCcExpr,
-
- unTagBinders, unTagBindersAlts,
-
-#ifdef DPH
- mkNonRecBinds,
- isParCoreCaseAlternative,
-#endif {- Data Parallel Haskell -}
-
- -- to make the interface self-sufficient...
- CoreAtom, CoreExpr, Id, UniType, UniqueSupply, UniqSM(..),
- IdEnv(..), UniqFM, Unique, TyVarEnv(..), Maybe
- ) where
-
---IMPORT_Trace -- ToDo: debugging only
-import Pretty
-
-import AbsPrel ( mkFunTy, trueDataCon, falseDataCon,
- eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
- buildId, augmentId,
- boolTyCon, fragilePrimOp,
- PrimOp(..), typeOfPrimOp,
- PrimKind
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-#ifdef DPH
- , mkPodTy, mkPodizedPodNTy
-#endif {- Data Parallel Haskell -}
- )
-import AbsUniType
-import BasicLit ( isNoRepLit, typeOfBasicLit, BasicLit(..)
- IF_ATTACK_PRAGMAS(COMMA isLitLitLit)
- )
-import CostCentre ( isDictCC, CostCentre )
-import Id
-import IdEnv
-import IdInfo
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Outputable
-import CoreSyn
-import PlainCore -- the main stuff we're defining functions for
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
-#ifdef DPH
-import TyCon ( getPodizedPodDimension )
-#endif {- Data Parallel Haskell -}
-import TyVarEnv
-import SplitUniq
-import Unique -- UniqueSupply monadery used here
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[bindersOf]{Small but useful}
-%* *
-%************************************************************************
-
-
-\begin{code}
-bindersOf :: CoreBinding bder bdee -> [bder]
-bindersOf (CoNonRec binder _) = [binder]
-bindersOf (CoRec pairs) = [binder | (binder,_) <- pairs]
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[typeOfCore]{Find the type of a Core atom/expression}
-%* *
-%************************************************************************
-
-\begin{code}
-typeOfCoreExpr :: PlainCoreExpr -> UniType
-typeOfCoreExpr (CoVar var) = getIdUniType var
-typeOfCoreExpr (CoLit lit) = typeOfBasicLit lit
-typeOfCoreExpr (CoLet binds body) = typeOfCoreExpr body
-typeOfCoreExpr (CoSCC label expr) = typeOfCoreExpr expr
-
--- a CoCon is a fully-saturated application of a data constructor
-typeOfCoreExpr (CoCon con tys _)
- = applyTyCon (getDataConTyCon con) tys
-
--- and, analogously, ...
-typeOfCoreExpr expr@(CoPrim op tys args)
- -- Note: CoPrims may be polymorphic, so we do de-forall'ing.
- = let
- op_ty = typeOfPrimOp op
- op_tau_ty = foldl applyTy op_ty tys
- in
- funResultTy op_tau_ty (length args)
-
-typeOfCoreExpr (CoCase _ alts) = typeOfCoreAlts alts
- -- Q: What if the one you happen to grab is an "error"?
- -- A: NO problem. The type application of error to its type will give you
- -- the answer.
-
-typeOfCoreExpr (CoLam binders expr)
- = foldr (mkFunTy . getIdUniType) (typeOfCoreExpr expr) binders
-
-typeOfCoreExpr (CoTyLam tyvar expr)
- = case (quantifyTy [tyvar] (typeOfCoreExpr expr)) of
- (_, ty) -> ty -- not worried about the TyVarTemplates that come back
-
-typeOfCoreExpr expr@(CoApp _ _) = typeOfCoreApp expr
-typeOfCoreExpr expr@(CoTyApp _ _) = typeOfCoreApp expr
-
-#ifdef DPH
-typeOfCoreExpr (CoParCon con ctxt tys args)
- = mkPodizedPodNTy ctxt (applyTyCon (getDataConTyCon con) tys)
-
-typeOfCoreExpr (CoZfExpr expr quals)
- = mkPodTy (typeOfCoreExpr expr)
-
-typeOfCoreExpr (CoParComm _ expr _)
- = typeOfCoreExpr expr
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-typeOfCoreApp application
- = case (collectArgs application) of { (fun, args) ->
- apply_args (typeOfCoreExpr fun) args
- }
- where
- apply_args expr_ty [] = expr_ty
-
- apply_args fun_ty (TypeArg ty_arg : args)
- = apply_args (applyTy fun_ty ty_arg) args
-
- apply_args fun_ty (ValArg val_arg : args)
- = case (maybeUnpackFunTy fun_ty) of
- Just (_, result_ty) -> apply_args result_ty args
-
- Nothing -> pprPanic "typeOfCoreApp:\n"
- (ppAboves
- [ppr PprDebug val_arg,
- ppr PprDebug fun_ty,
- ppr PprShowAll application])
-\end{code}
-
-\begin{code}
-typeOfCoreAlts :: PlainCoreCaseAlternatives -> UniType
-typeOfCoreAlts (CoAlgAlts [] deflt) = typeOfDefault deflt
-typeOfCoreAlts (CoAlgAlts ((_,_,rhs1):_) _) = typeOfCoreExpr rhs1
-
-typeOfCoreAlts (CoPrimAlts [] deflt) = typeOfDefault deflt
-typeOfCoreAlts (CoPrimAlts ((_,rhs1):_) _) = typeOfCoreExpr rhs1
-#ifdef DPH
-typeOfCoreAlts (CoParAlgAlts _ _ _ [] deflt) = typeOfDefault deflt
-typeOfCoreAlts (CoParAlgAlts _ _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1
-
-typeOfCoreAlts (CoParPrimAlts _ _ [] deflt) = typeOfDefault deflt
-typeOfCoreAlts (CoParPrimAlts _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1
-#endif {- Data Parallel Haskell -}
-
-typeOfDefault CoNoDefault = panic "typeOfCoreExpr:CoCase:typeOfDefault"
-typeOfDefault (CoBindDefault _ rhs) = typeOfCoreExpr rhs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CoreFuns-instantiate]{Instantiating core expressions: interfaces}
-%* *
-%************************************************************************
-
-These subst/inst functions {\em must not} use splittable
-UniqueSupplies! (yet)
-
-All of the desired functions are done by one piece of code, which
-carries around a little (monadised) state (a @UniqueSupply@).
-Meanwhile, here is what the outside world sees (NB: @UniqueSupply@
-passed in and out):
-\begin{code}
-{- UNUSED:
-cloneCoreExpr :: UniqueSupply
- -> PlainCoreExpr -- template
- -> (UniqueSupply, PlainCoreExpr)
-
-cloneCoreExpr us expr = instCoreExpr us expr
--}
-
---------------------
-
-instCoreExpr :: UniqueSupply
- -> PlainCoreExpr
- -> (UniqueSupply, PlainCoreExpr)
-
-instCoreExpr us expr
- = initUs us (do_CoreExpr nullIdEnv nullTyVarEnv expr)
-
-instCoreBindings :: UniqueSupply
- -> [PlainCoreBinding]
- -> (UniqueSupply, [PlainCoreBinding])
-
-instCoreBindings us binds
- = initUs us (do_CoreBindings nullIdEnv nullTyVarEnv binds)
-
---------------------
-
-substCoreExpr :: UniqueSupply
- -> ValEnv
- -> TypeEnv -- TyVar=>UniType
- -> PlainCoreExpr
- -> (UniqueSupply, PlainCoreExpr)
-
-substCoreExpr us venv tenv expr
- = initUs us (substCoreExprUS venv tenv expr)
-
--- we are often already in a UniqSM world, so here are the interfaces
--- for that:
-{- UNUSED:
-cloneCoreExprUS :: PlainCoreExpr{-template-} -> UniqSM PlainCoreExpr
-
-cloneCoreExprUS = instCoreExprUS
-
-instCoreExprUS :: PlainCoreExpr -> UniqSM PlainCoreExpr
-
-instCoreExprUS expr = do_CoreExpr nullIdEnv nullTyVarEnv expr
--}
-
---------------------
-
-substCoreExprUS :: ValEnv
- -> TypeEnv -- TyVar=>UniType
- -> PlainCoreExpr
- -> UniqSM PlainCoreExpr
-
-substCoreExprUS venv tenv expr
- -- if the envs are empty, then avoid doing anything
- = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
- returnUs expr
- else
- do_CoreExpr venv tenv expr
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CoreFuns-inst-exprs]{Actual expression-instantiating code}
-%* *
-%************************************************************************
-
-The equiv code for @UniTypes@ is in @UniTyFuns@.
-
-Because binders aren't necessarily unique: we don't do @plusEnvs@
-(which check for duplicates); rather, we use the shadowing version,
-@growIdEnv@ (and shorthand @addOneToIdEnv@).
-
-\begin{code}
-type ValEnv = IdEnv PlainCoreExpr
-
-do_CoreBinding :: ValEnv
- -> TypeEnv
- -> PlainCoreBinding
- -> UniqSM (PlainCoreBinding, ValEnv)
-
-do_CoreBinding venv tenv (CoNonRec binder rhs)
- = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
-
- dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
- -- now plug new bindings into envs
- let new_venv = addOneToIdEnv venv old new in
-
- returnUs (CoNonRec new_binder new_rhs, new_venv)
-
-do_CoreBinding venv tenv (CoRec binds)
- = -- for letrec, we plug in new bindings BEFORE cloning rhss
- mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
- let new_venv = growIdEnvList venv new_maps in
-
- mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
- returnUs (CoRec (new_binders `zip` new_rhss), new_venv)
- where
- binders = map fst binds
- rhss = map snd binds
-\end{code}
-
-@do_CoreBindings@ takes into account the semantics of a list of
-@CoreBindings@---things defined early in the list are visible later in
-the list, but not vice versa.
-
-\begin{code}
-do_CoreBindings :: ValEnv
- -> TypeEnv
- -> [PlainCoreBinding]
- -> UniqSM [PlainCoreBinding]
-
-do_CoreBindings venv tenv [] = returnUs []
-do_CoreBindings venv tenv (b:bs)
- = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
- do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
- returnUs (new_b : new_bs)
-\end{code}
-
-\begin{code}
-do_CoreAtom :: ValEnv
- -> TypeEnv
- -> PlainCoreAtom
- -> UniqSM PlainCoreExpr
-
-do_CoreAtom venv tenv a@(CoLitAtom lit) = returnUs (CoLit lit)
-
-do_CoreAtom venv tenv orig_a@(CoVarAtom v)
- = returnUs (
- case (lookupIdEnv venv v) of
- Nothing -> --false:ASSERT(toplevelishId v)
- CoVar v
- Just expr -> expr
- )
-\end{code}
-
-\begin{code}
-do_CoreExpr :: ValEnv
- -> TypeEnv
- -> PlainCoreExpr
- -> UniqSM PlainCoreExpr
-
-do_CoreExpr venv tenv orig_expr@(CoVar var)
- = returnUs (
- case (lookupIdEnv venv var) of
- Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
- orig_expr
- Just expr -> expr
- )
-
-do_CoreExpr venv tenv e@(CoLit _) = returnUs e
-
-do_CoreExpr venv tenv (CoCon con ts as)
- = let
- new_ts = map (applyTypeEnvToTy tenv) ts
- in
- mapUs (do_CoreAtom venv tenv) as `thenUs` \ new_as ->
- mkCoCon con new_ts new_as
-
-do_CoreExpr venv tenv (CoPrim op tys as)
- = let
- new_tys = map (applyTypeEnvToTy tenv) tys
- in
- mapUs (do_CoreAtom venv tenv) as `thenUs` \ new_as ->
- do_PrimOp op `thenUs` \ new_op ->
- mkCoPrim new_op new_tys new_as
- where
- do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
- = let
- new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
- new_result_ty = applyTypeEnvToTy tenv result_ty
- in
- returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
-
- do_PrimOp other_op = returnUs other_op
-
-do_CoreExpr venv tenv (CoLam binders expr)
- = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
- let new_venv = growIdEnvList venv new_maps in
- do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (CoLam new_binders new_expr)
-
-do_CoreExpr venv tenv (CoTyLam 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 (CoTyLam new_tyvar new_expr)
-
-do_CoreExpr venv tenv (CoApp expr atom)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- do_CoreAtom venv tenv atom `thenUs` \ new_atom ->
- mkCoApp new_expr new_atom
-
-do_CoreExpr venv tenv (CoTyApp expr ty)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- let
- new_ty = applyTypeEnvToTy tenv ty
- in
- returnUs (CoTyApp new_expr new_ty)
-
-do_CoreExpr venv tenv (CoCase expr alts)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- do_alts venv tenv alts `thenUs` \ new_alts ->
- returnUs (CoCase new_expr new_alts)
- where
- do_alts venv tenv (CoAlgAlts alts deflt)
- = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
- do_default venv tenv deflt `thenUs` \ new_deflt ->
- returnUs (CoAlgAlts new_alts new_deflt)
- where
- do_boxed_alt venv tenv (con, binders, expr)
- = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
- let new_venv = growIdEnvList venv new_vmaps in
- do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (con, new_binders, new_expr)
-
-
- do_alts venv tenv (CoPrimAlts alts deflt)
- = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
- do_default venv tenv deflt `thenUs` \ new_deflt ->
- returnUs (CoPrimAlts new_alts new_deflt)
- where
- do_unboxed_alt venv tenv (lit, expr)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- returnUs (lit, new_expr)
-#ifdef DPH
- do_alts venv tenv (CoParAlgAlts tycon dim params alts deflt)
- = mapAndUnzipUs (dup_binder tenv) params `thenUs` \ (new_params,new_vmaps) ->
- let new_venv = growIdEnvList venv new_vmaps in
- mapUs (do_boxed_alt new_venv tenv) alts
- `thenUs` \ new_alts ->
- do_default venv tenv deflt `thenUs` \ new_deflt ->
- returnUs (CoParAlgAlts tycon dim new_params new_alts new_deflt)
- where
- do_boxed_alt venv tenv (con, expr)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- returnUs (con, new_expr)
-
- do_alts venv tenv (CoParPrimAlts tycon dim alts deflt)
- = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
- do_default venv tenv deflt `thenUs` \ new_deflt ->
- returnUs (CoParPrimAlts tycon dim new_alts new_deflt)
- where
- do_unboxed_alt venv tenv (lit, expr)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- returnUs (lit, new_expr)
-#endif {- Data Parallel Haskell -}
-
- do_default venv tenv CoNoDefault = returnUs CoNoDefault
-
- do_default venv tenv (CoBindDefault 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 (CoBindDefault new_binder new_expr)
-
-do_CoreExpr venv tenv (CoLet core_bind expr)
- = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
- -- and do the body of the let
- do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (CoLet new_bind new_expr)
-
-do_CoreExpr venv tenv (CoSCC label expr)
- = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
- returnUs (CoSCC label new_expr)
-
-#ifdef DPH
-do_CoreExpr venv tenv (CoParCon con ctxt ts es)
- = let
- new_ts = map (applyTypeEnvToTy tenv) ts
- in
- mapUs (do_CoreExpr venv tenv) es) `thenUs` \ new_es ->
- returnUs (CoParCon con ctxt new_ts new_es)
-
-do_CoreExpr venv tenv (CoZfExpr expr quals)
- = do_CoreParQuals venv tenv quals `thenUs` \ (quals',venv') ->
- do_CoreExpr venv' tenv expr `thenUs` \ expr' ->
- returnUs (CoZfExpr expr' quals')
-
-do_CoreExpr venv tenv (CoParComm dim expr comm)
- = do_CoreExpr venv tenv expr `thenUs` \ expr' ->
- do_ParComm comm `thenUs` \ comm' ->
- returnUs (CoParComm dim expr' comm')
- where
- do_ParComm (CoParSend exprs)
- = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' ->
- returnUs (CoParSend exprs')
- do_ParComm (CoParFetch exprs)
- = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' ->
- returnUs (CoParFetch exprs')
- do_ParComm (CoToPodized)
- = returnUs (CoToPodized)
- do_ParComm (CoFromPodized)
- = returnUs (CoFromPodized)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DPH
-do_CoreParQuals :: ValEnv
- -> TypeEnv
- -> PlainCoreParQuals
- -> UniqSM (PlainCoreParQuals, ValEnv)
-
-do_CoreParQuals venv tenv (CoAndQuals l r)
- = do_CoreParQuals venv tenv r `thenUs` \ (r',right_venv) ->
- do_CoreParQuals right_venv tenv l `thenUs` \ (l',left_env) ->
- returnUs (CoAndQuals l' r',left_env)
-
-do_CoreParQuals venv tenv (CoParFilter expr)
- = do_CoreExpr venv tenv expr `thenUs` \ expr' ->
- returnUs (CoParFilter expr',venv))
-
-do_CoreParQuals venv tenv (CoDrawnGen binders binder expr)
- = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (newBs,newMs) ->
- let new_venv = growIdEnvList venv newMs in
- dup_binder tenv binder `thenUs` \ (newB,(old,new)) ->
- let new_venv' = addOneToIdEnv new_venv old new in
- do_CoreExpr new_venv' tenv expr `thenUs` \ new_expr ->
- returnUs (CoDrawnGen newBs newB new_expr,new_venv')
-
-do_CoreParQuals venv tenv (CoIndexGen exprs binder expr)
- = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ new_exprs ->
- dup_binder tenv binder `thenUs` \ (newB,(old,new)) ->
- let new_venv = addOneToIdEnv venv old new in
- do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (CoIndexGen new_exprs newB new_expr,new_venv)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, UniType))
-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, PlainCoreExpr))
-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, CoVar 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, CoVar new_b2))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[mk_CoreExpr_bits]{Routines to manufacture bits of @CoreExpr@}
-%* *
-%************************************************************************
-
-When making @CoLets@, we may want to take evasive action if the thing
-being bound has unboxed type. We have different variants ...
-
-@mkCoLet(s|rec)Any@ let-binds any binding, regardless of type
-@mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings
-@mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case
- (unboxed bindings in a letrec are still prohibited)
-
-\begin{code}
-mkCoLetAny :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
-
-mkCoLetAny bind@(CoRec binds) body
- = mkCoLetrecAny binds body
-mkCoLetAny bind@(CoNonRec binder rhs) body
- = case body of
- CoVar binder2 | binder `eqId` binder2
- -> rhs -- hey, I have the rhs
- other
- -> CoLet bind body
-
-mkCoLetsAny [] expr = expr
-mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
-
-mkCoLetrecAny :: [(Id, PlainCoreExpr)] -- bindings
- -> PlainCoreExpr -- body
- -> PlainCoreExpr -- result
-
-mkCoLetrecAny [] body = body
-mkCoLetrecAny binds body
- = CoLet (CoRec binds) body
-\end{code}
-
-\begin{code}
-mkCoLetNoUnboxed :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
-
-mkCoLetNoUnboxed bind@(CoRec binds) body
- = mkCoLetrecNoUnboxed binds body
-mkCoLetNoUnboxed bind@(CoNonRec binder rhs) body
- = ASSERT (not (isUnboxedDataType (getIdUniType binder)))
- case body of
- CoVar binder2 | binder `eqId` binder2
- -> rhs -- hey, I have the rhs
- other
- -> CoLet bind body
-
-mkCoLetsNoUnboxed [] expr = expr
-mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
-
-mkCoLetrecNoUnboxed :: [(Id, PlainCoreExpr)] -- bindings
- -> PlainCoreExpr -- body
- -> PlainCoreExpr -- result
-
-mkCoLetrecNoUnboxed [] body = body
-mkCoLetrecNoUnboxed binds body
- = ASSERT (all is_boxed_bind binds)
- CoLet (CoRec binds) body
- where
- is_boxed_bind (binder, rhs)
- = (not . isUnboxedDataType . getIdUniType) binder
-\end{code}
-
-\begin{code}
-mkCoLetUnboxedToCase :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
-
-mkCoLetUnboxedToCase bind@(CoRec binds) body
- = mkCoLetrecNoUnboxed binds body
-mkCoLetUnboxedToCase bind@(CoNonRec binder rhs) body
- = case body of
- CoVar binder2 | binder `eqId` binder2
- -> rhs -- hey, I have the rhs
- other
- -> if (not (isUnboxedDataType (getIdUniType binder))) then
- CoLet bind body -- boxed...
- else
-#ifdef DPH
- let (tycon,_,_) = getUniDataTyCon (getIdUniType binder) in
- if isPodizedPodTyCon tycon
- then CoCase rhs
- (CoParPrimAlts tycon (getPodizedPodDimension tycon) []
- (CoBindDefault binder body))
- else
-#endif {- DPH -}
- CoCase rhs -- unboxed...
- (CoPrimAlts []
- (CoBindDefault binder body))
-
-mkCoLetsUnboxedToCase [] expr = expr
-mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
-\end{code}
-
-Clump CoLams together if possible; friendlier to the code generator.
-
-\begin{code}
-mkCoLam :: [binder] -> CoreExpr binder bindee -> CoreExpr binder bindee
-mkCoLam [] body = body
-mkCoLam binders body
- = case (digForLambdas body) of { (tyvars, body_binders, body_expr) ->
- if not (null tyvars) then
- pprTrace "Inner /\\'s:" (ppr PprDebug tyvars)
- (CoLam binders (mkCoTyLam tyvars (mkCoLam body_binders body_expr)))
- else
- CoLam (binders ++ body_binders) body_expr
- }
-
-mkCoTyLam :: [TyVar] -> CoreExpr binder bindee -> CoreExpr binder bindee
-mkCoTyLam tvs body = foldr CoTyLam body tvs
-
-mkCoTyApps :: CoreExpr binder bindee -> [UniType] -> CoreExpr binder bindee
-mkCoTyApps expr tys = foldl mkCoTyApp expr tys
-\end{code}
-
-\begin{code}
-mkCoreIfThenElse (CoVar bool) then_expr else_expr
- | bool `eqId` trueDataCon = then_expr
- | bool `eqId` falseDataCon = else_expr
-
-mkCoreIfThenElse guard then_expr else_expr
- = CoCase guard
- (CoAlgAlts [ (trueDataCon, [], then_expr),
- (falseDataCon, [], else_expr) ]
- CoNoDefault )
-\end{code}
-
-\begin{code}
-mkErrorCoApp :: UniType -> Id -> String -> PlainCoreExpr
-
-mkErrorCoApp ty str_var error_msg
---OLD: | not (isPrimType ty)
- = CoLet (CoNonRec str_var (CoLit (NoRepStr (_PK_ error_msg)))) (
- CoApp (CoTyApp (CoVar pAT_ERROR_ID) ty) (CoVarAtom str_var))
-{- TOO PARANOID: removed 95/02 WDP
- | otherwise
- -- for now, force the user to write their own suitably-typed error msg
- = error (ppShow 80 (ppAboves [
- ppStr "ERROR: can't generate a pattern-matching error message",
- ppStr " when a primitive type is involved.",
- ppCat [ppStr "Type:", ppr PprDebug ty],
- ppCat [ppStr "Var :", ppr PprDebug str_var],
- ppCat [ppStr "Msg :", ppStr error_msg]
- ]))
--}
-
-escErrorMsg [] = []
-escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
-escErrorMsg (x:xs) = x : escErrorMsg xs
-\end{code}
-
-For making @CoApps@ and @CoLets@, we must take appropriate evasive
-action if the thing being bound has unboxed type. @mkCoApp@ requires
-a name supply to do its work. Other-monad code will call @mkCoApp@
-through its own interface function (e.g., the desugarer uses
-@mkCoAppDs@).
-
-@mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
-arguments-must-be-atoms constraint.
-
-\begin{code}
-mkCoApp :: PlainCoreExpr -> PlainCoreExpr -> UniqSM PlainCoreExpr
-
-mkCoApp e1 (CoVar v) = returnUs (CoApp e1 (CoVarAtom v))
-mkCoApp e1 (CoLit l) = returnUs (CoApp e1 (CoLitAtom l))
-mkCoApp e1 e2
- = let
- e2_ty = typeOfCoreExpr e2
- in
- getUnique `thenUs` \ uniq ->
- let
- new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
- in
- returnUs (
- mkCoLetUnboxedToCase (CoNonRec new_var e2)
- (CoApp e1 (CoVarAtom new_var))
- )
-\end{code}
-
-\begin{code}
-mkCoCon :: Id -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
-mkCoPrim :: PrimOp -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
-
-mkCoCon con tys args = mkCoThing (CoCon con) tys args
-mkCoPrim op tys args = mkCoThing (CoPrim op) tys args
-
-mkCoThing thing tys args
- = mapAndUnzipUs expr_to_atom args `thenUs` \ (atoms, maybe_binds) ->
- returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing tys atoms))
- where
- expr_to_atom :: PlainCoreExpr
- -> UniqSM (PlainCoreAtom, Maybe PlainCoreBinding)
-
- expr_to_atom (CoVar v) = returnUs (CoVarAtom v, Nothing)
- expr_to_atom (CoLit l) = returnUs (CoLitAtom l, Nothing)
- expr_to_atom other_expr
- = let
- e_ty = typeOfCoreExpr other_expr
- in
- getUnique `thenUs` \ uniq ->
- let
- new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
- new_atom = CoVarAtom new_var
- in
- returnUs (new_atom, Just (CoNonRec new_var other_expr))
-\end{code}
-
-\begin{code}
-atomToExpr :: CoreAtom bindee -> CoreExpr binder bindee
-
-atomToExpr (CoVarAtom v) = CoVar v
-atomToExpr (CoLitAtom lit) = CoLit lit
-\end{code}
-
-\begin{code}
-pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
-
-pairsFromCoreBinds [] = []
-pairsFromCoreBinds ((CoNonRec b e) : bs) = (b,e) : (pairsFromCoreBinds bs)
-pairsFromCoreBinds ((CoRec pairs) : bs) = pairs ++ (pairsFromCoreBinds bs)
-\end{code}
-
-\begin{code}
-#ifdef DPH
-mkNonRecBinds :: [(a, CoreExpr a b)] -> [CoreBinding a b]
-mkNonRecBinds xs = [ CoNonRec b e | (b,e) <- xs ]
-
-isParCoreCaseAlternative :: CoreCaseAlternatives a b -> Bool
-{-
-isParCoreCaseAlternative (CoParAlgAlts _ _ _ _ _) = True
-isParCoreCaseAlternative (CoParPrimAlts _ _ _ _) = True
--}
-isParCoreCaseAlternative _ = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-mkFunction tys args e
- = foldr CoTyLam (mkCoLam args e) tys
-
-mkCoApps :: PlainCoreExpr -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
-
-mkCoApps fun [] = returnUs fun
-mkCoApps fun (arg:args)
- = mkCoApp fun arg `thenUs` \ new_fun ->
- mkCoApps new_fun args
-\end{code}
-
-We often want to strip off leading \tr{/\}-bound @TyVars@ and
-\tr{\}-bound binders, before we get down to business. @digForLambdas@
-is your friend.
-
-\begin{code}
-digForLambdas :: CoreExpr bndr bdee -> ([TyVar], [bndr], CoreExpr bndr bdee)
-
-digForLambdas (CoTyLam tyvar body)
- = let
- (tyvars, args, final_body) = digForLambdas body
- in
- (tyvar:tyvars, args, final_body)
-
-digForLambdas other
- = let
- (args, body) = dig_in_lambdas other
- in
- ([], args, body)
- where
- dig_in_lambdas (CoLam args_here body)
- = let
- (args, final_body) = dig_in_lambdas body
- in
- (args_here ++ args, final_body)
-
-#ifdef DEBUG
- dig_in_lambdas body@(CoTyLam ty expr)
- = trace "Inner /\\'s when digging" ([],body)
-#endif
-
- dig_in_lambdas body
- = ([], body)
-\end{code}
-
-\begin{code}
-exprSmallEnoughToDup :: CoreExpr binder Id -> Bool
-
-exprSmallEnoughToDup (CoCon _ _ _) = True -- Could check # of args
-exprSmallEnoughToDup (CoPrim op _ _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (CoLit lit) = not (isNoRepLit lit)
-
-exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
- = case (collectArgs expr) of { (fun, args) ->
- case fun of
- CoVar v -> v /= buildId
- && v /= augmentId
- && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
- _ -> False
- }
-\end{code}
-Question (ADR): What is the above used for? Is a _ccall_ really small
-enough?
-
-@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
-it is obviously in weak head normal form. It isn't a disaster if it
-errs on the conservative side (returning \tr{False})---I've probably
-left something out... [WDP]
-
-\begin{code}
-manifestlyWHNF :: CoreExpr bndr Id -> Bool
-
-manifestlyWHNF (CoVar _) = True
-manifestlyWHNF (CoLit _) = True
-manifestlyWHNF (CoCon _ _ _) = True -- ToDo: anything for CoPrim?
-manifestlyWHNF (CoLam _ _) = True
-manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
-manifestlyWHNF (CoSCC _ e) = manifestlyWHNF e
-manifestlyWHNF (CoLet _ e) = False
-manifestlyWHNF (CoCase _ _) = False
-
-manifestlyWHNF other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, args) ->
- case fun of
- CoVar f -> let
- num_val_args = length [ a | (ValArg a) <- args ]
- in
- num_val_args == 0 || -- Just a type application of
- -- a variable (f t1 t2 t3)
- -- counts as WHNF
- case (arityMaybe (getIdArity f)) of
- Nothing -> False
- Just arity -> num_val_args < arity
-
- _ -> False
- }
-\end{code}
-
-@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
-it is obviously bottom, that is, it will certainly return bottom at
-some point. It isn't a disaster if it errs on the conservative side
-(returning \tr{False}).
-
-\begin{code}
-manifestlyBottom :: CoreExpr bndr Id -> Bool
-
-manifestlyBottom (CoVar v) = isBottomingId v
-manifestlyBottom (CoLit _) = False
-manifestlyBottom (CoCon _ _ _) = False
-manifestlyBottom (CoPrim _ _ _)= False
-manifestlyBottom (CoLam _ _) = False -- we do not assume \x.bottom == bottom. should we? ToDo
-manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
-manifestlyBottom (CoSCC _ e) = manifestlyBottom e
-manifestlyBottom (CoLet _ e) = manifestlyBottom e
-
-manifestlyBottom (CoCase e a)
- = manifestlyBottom e
- || (case a of
- CoAlgAlts alts def -> all mbalg alts && mbdef def
- CoPrimAlts alts def -> all mbprim alts && mbdef def
- )
- where
- mbalg (_,_,e') = manifestlyBottom e'
-
- mbprim (_,e') = manifestlyBottom e'
-
- mbdef CoNoDefault = True
- mbdef (CoBindDefault _ e') = manifestlyBottom e'
-
-manifestlyBottom other_expr -- look for manifest partial application
- = case (collectArgs other_expr) of { (fun, args) ->
- case fun of
- CoVar f | isBottomingId f -> True -- Application of a function which
- -- always gives bottom; we treat this as
- -- a WHNF, because it certainly doesn't
- -- need to be shared!
- _ -> False
- }
-\end{code}
-
-UNUSED: @manifestWHNFArgs@ guarantees that an expression can absorb n args
-before it ceases to be a manifest WHNF. E.g.,
-\begin{verbatim}
- (\x->x) gives 1
- (\x -> +Int x) gives 2
-\end{verbatim}
-
-The function guarantees to err on the side of conservatism: the
-conservative result is (Just 0).
-
-An applications of @error@ are special, because it can absorb as many
-arguments as you care to give it. For this special case we return Nothing.
-
-\begin{code}
-{- UNUSED:
-manifestWHNFArgs :: CoreExpr bndr Id
- -> Maybe Int -- Nothing indicates applicn of "error"
-
-manifestWHNFArgs expr
- = my_trace (man expr)
- where
- man (CoLit _) = Just 0
- man (CoCon _ _ _) = Just 0
- man (CoLam bs e) = man e `plus_args` length bs
- man (CoApp e _) = man e `minus_args` 1
- man (CoTyLam _ e) = man e
- man (CoSCC _ e) = man e
- man (CoLet _ e) = man e
-
- man (CoVar f)
- | isBottomingId f = Nothing
- | otherwise = case (arityMaybe (getIdArity f)) of
- Nothing -> Just 0
- Just arity -> Just arity
-
- man other = Just 0 -- Give up on case
-
- plus_args, minus_args :: Maybe Int -> Int -> Maybe Int
-
- plus_args Nothing m = Nothing
- plus_args (Just n) m = Just (n+m)
-
- minus_args Nothing m = Nothing
- minus_args (Just n) m = Just (n-m)
-
- my_trace n = n
- -- if n == 0 then n
- -- else pprTrace "manifest:" (ppCat [ppr PprDebug fun,
- -- ppr PprDebug args, ppStr "=>", ppInt n])
- -- n
--}
-\end{code}
-
-\begin{code}
-coreExprArity
- :: (Id -> Maybe (CoreExpr bndr Id))
- -> CoreExpr bndr Id
- -> Int
-coreExprArity f (CoLam bnds expr) = coreExprArity f expr + length (bnds)
-coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
-coreExprArity f (CoApp expr arg) = max (coreExprArity f expr - 1) 0
-coreExprArity f (CoTyApp expr _) = coreExprArity f expr
-coreExprArity f (CoVar v) = max further info
- where
- further
- = case f v of
- Nothing -> 0
- Just expr -> coreExprArity f expr
- info = case (arityMaybe (getIdArity v)) of
- Nothing -> 0
- Just arity -> arity
-coreExprArity f _ = 0
-\end{code}
-
-@isWrapperFor@: we want to see exactly:
-\begin{verbatim}
-/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
-\end{verbatim}
-
-Probably a little too HACKY [WDP].
-
-\begin{code}
-isWrapperFor :: PlainCoreExpr -> Id -> Bool
-
-expr `isWrapperFor` var
- = case (digForLambdas expr) of { (_, args, body) -> -- lambdas off the front
- unravel_casing args body
- --NO, THANKS: && not (null args)
- }
- where
- var's_worker = getWorkerId (getIdStrictness var)
-
- is_elem = isIn "isWrapperFor"
-
- --------------
- unravel_casing case_ables (CoCase scrut alts)
- = case (collectArgs scrut) of { (fun, args) ->
- case fun of
- CoVar scrut_var -> let
- answer =
- scrut_var /= var && all (doesn't_mention var) args
- && scrut_var `is_elem` case_ables
- && unravel_alts case_ables alts
- in
- answer
-
- _ -> False
- }
-
- unravel_casing case_ables other_expr
- = case (collectArgs other_expr) of { (fun, args) ->
- case fun of
- CoVar wrkr -> let
- answer =
- -- DOESN'T WORK: wrkr == var's_worker
- wrkr /= var
- && isWorkerId wrkr
- && all (doesn't_mention var) args
- && all (only_from case_ables) args
- in
- answer
-
- _ -> False
- }
-
- --------------
- unravel_alts case_ables (CoAlgAlts [(_,params,rhs)] CoNoDefault)
- = unravel_casing (params ++ case_ables) rhs
- unravel_alts case_ables other = False
-
- -------------------------
- doesn't_mention var (ValArg (CoVarAtom v)) = v /= var
- doesn't_mention var other = True
-
- -------------------------
- only_from case_ables (ValArg (CoVarAtom v)) = v `is_elem` case_ables
- only_from case_ables other = True
-\end{code}
-
-All the following functions operate on binders, perform a uniform
-transformation on them; ie. the function @(\ x -> (x,False))@
-annotates all binders with False.
-
-\begin{code}
-unTagBinders :: CoreExpr (Id,tag) bdee -> CoreExpr Id bdee
-unTagBinders e = bop_expr fst e
-
-unTagBindersAlts :: CoreCaseAlternatives (Id,tag) bdee -> CoreCaseAlternatives Id bdee
-unTagBindersAlts alts = bop_alts fst alts
-\end{code}
-
-\begin{code}
-bop_expr :: (a -> b) -> (CoreExpr a c) -> CoreExpr b c
-
-bop_expr f (CoVar b) = CoVar b
-bop_expr f (CoLit lit) = CoLit lit
-bop_expr f (CoCon id u atoms) = CoCon id u atoms
-bop_expr f (CoPrim op tys atoms)= CoPrim op tys atoms
-bop_expr f (CoLam binders expr) = CoLam [ f x | x <- binders ] (bop_expr f expr)
-bop_expr f (CoTyLam ty expr) = CoTyLam ty (bop_expr f expr)
-bop_expr f (CoApp expr atom) = CoApp (bop_expr f expr) atom
-bop_expr f (CoTyApp expr ty) = CoTyApp (bop_expr f expr) ty
-bop_expr f (CoSCC label expr) = CoSCC label (bop_expr f expr)
-bop_expr f (CoLet bind expr) = CoLet (bop_bind f bind) (bop_expr f expr)
-bop_expr f (CoCase expr alts)
- = CoCase (bop_expr f expr) (bop_alts f alts)
-
-bop_bind f (CoNonRec b e) = CoNonRec (f b) (bop_expr f e)
-bop_bind f (CoRec pairs) = CoRec [(f b, bop_expr f e) | (b, e) <- pairs]
-
-bop_alts f (CoAlgAlts alts deflt)
- = CoAlgAlts [ (con, [f b | b <- binders], bop_expr f e)
- | (con, binders, e) <- alts ]
- (bop_deflt f deflt)
-
-bop_alts f (CoPrimAlts alts deflt)
- = CoPrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
- (bop_deflt f deflt)
-
-bop_deflt f (CoNoDefault) = CoNoDefault
-bop_deflt f (CoBindDefault b expr) = CoBindDefault (f b) (bop_expr f expr)
-
-#ifdef DPH
-bop_expr f (CoZfExpr expr quals)
- = CoZfExpr (bop_expr f expr) (bop_quals quals)
- where
- bop_quals (CoAndQuals l r) = CoAndQuals (bop_quals l) (bop_quals r)
- bop_quals (CoParFilter e) = CoParFilter (bop_expr f e)
- bop_quals (CoDrawnGen bs b e) = CoDrawnGen (map f bs) (f b) (bop_expr f e)
- bop_quals (CoIndexGen es b e) = CoIndexGen (map (bop_expr f) es) (f b)
- (bop_expr f e)
-
-bop_expr f (CoParCon con ctxt tys args)
- = CoParCon con ctxt tys (map (bop_expr f) args)
-
-bop_expr f (CoParComm ctxt e comm)
- = CoParComm ctxt (bop_expr f e) (bop_comm comm)
- where
- bop_comm (CoParSend es) = CoParSend (map (bop_expr f) es)
- bop_comm (CoParFetch es) = CoParFetch (map (bop_expr f) es)
- bop_comm (CoToPodized) = CoToPodized
- bop_comm (CoFromPodized) = CoFromPodized
-#endif {- DPH -}
-\end{code}
-
-OLD (but left here because of the nice example): @singleAlt@ checks
-whether a bunch of case alternatives is actually just one alternative.
-It specifically {\em ignores} alternatives which consist of just a
-call to @error@, because they won't result in any code duplication.
-
-Example:
-\begin{verbatim}
- case (case <something> of
- True -> <rhs>
- False -> error "Foo") of
- <alts>
-
-===>
-
- case <something> of
- True -> case <rhs> of
- <alts>
- False -> case error "Foo" of
- <alts>
-
-===>
-
- case <something> of
- True -> case <rhs> of
- <alts>
- False -> error "Foo"
-\end{verbatim}
-Notice that the \tr{<alts>} don't get duplicated.
-
-\begin{code}
-{- UNUSED:
-boilsDownToConApp :: CoreExpr bndr bdee -> Bool -- Looks through lets
- -- ToDo: could add something for NoRep literals...
-
-boilsDownToConApp (CoCon _ _ _) = True
-boilsDownToConApp (CoTyLam _ e) = boilsDownToConApp e
-boilsDownToConApp (CoTyApp e _) = boilsDownToConApp e
-boilsDownToConApp (CoLet _ e) = boilsDownToConApp e
-boilsDownToConApp other = False
--}
-\end{code}
-
-\begin{code}
-nonErrorRHSs :: CoreCaseAlternatives binder Id -> [CoreExpr binder Id]
-
-nonErrorRHSs alts = filter not_error_app (find_rhss alts)
- where
- find_rhss (CoAlgAlts alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
- find_rhss (CoPrimAlts alts deflt) = [rhs | (_,rhs) <- alts] ++ deflt_rhs deflt
-
- deflt_rhs CoNoDefault = []
- deflt_rhs (CoBindDefault _ rhs) = [rhs]
-
- not_error_app rhs = case maybeErrorApp rhs Nothing of
- Just _ -> False
- Nothing -> True
-\end{code}
-
-maybeErrorApp checkes whether an expression is of the form
-
- error ty args
-
-If so, it returns
-
- Just (error ty' args)
-
-where ty' is supplied as an argument to maybeErrorApp.
-
-Here's where it is useful:
-
- case (error ty "Foo" e1 e2) of <alts>
- ===>
- error ty' "Foo"
-
-where ty' is the type of any of the alternatives.
-You might think this never occurs, but see the comments on
-the definition of @singleAlt@.
-
-Note: we *avoid* the case where ty' might end up as a
-primitive type: this is very uncool (totally wrong).
-
-NOTICE: in the example above we threw away e1 and e2, but
-not the string "Foo". How did we know to do that?
-
-Answer: for now anyway, we only handle the case of a function
-whose type is of form
-
- bottomingFn :: forall a. t1 -> ... -> tn -> a
- ^---------------------^ NB!
-
-Furthermore, we only count a bottomingApp if the function is
-applied to more than n args. If so, we transform:
-
- bottomingFn ty e1 ... en en+1 ... em
-to
- bottomingFn ty' e1 ... en
-
-That is, we discard en+1 .. em
-
-\begin{code}
-maybeErrorApp :: CoreExpr bndr Id -- Expr to look at
- -> Maybe UniType -- Just ty => a result type *already cloned*;
- -- Nothing => don't know result ty; we
- -- *pretend* that the result ty won't be
- -- primitive -- somebody later must
- -- ensure this.
- -> Maybe (CoreExpr bndr Id)
-
-maybeErrorApp expr result_ty_maybe
- = case collectArgs expr of
- (CoVar fun, (TypeArg ty : other_args))
- | isBottomingId fun
- && maybeToBool result_ty_maybe -- we *know* the result type
- -- (otherwise: live a fairy-tale existence...)
- && not (isPrimType result_ty) ->
- case splitType (getIdUniType fun) of
- ([tyvar_tmpl], [], tau_ty) ->
- case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
- let
- n_args_to_keep = length arg_tys
- args_to_keep = take n_args_to_keep other_args
- in
- if res_ty == mkTyVarTemplateTy tyvar_tmpl &&
- n_args_to_keep <= length other_args
- then
- -- Phew! We're in business
- Just (applyToArgs (CoVar fun)
- (TypeArg result_ty : args_to_keep))
- else
- Nothing
- }
-
- other -> -- Function type wrong shape
- Nothing
- other -> Nothing
- where
- Just result_ty = result_ty_maybe
-\end{code}
-
-\begin{code}
-squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
-
-squashableDictishCcExpr cc expr
- = if not (isDictCC cc) then
- False -- that was easy...
- else
- squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
- where
- squashable (CoVar _) = True
- squashable (CoTyApp f _) = squashable f
- squashable (CoCon _ _ _) = True -- I think so... WDP 94/09
- squashable (CoPrim _ _ _) = True -- ditto
- squashable other = False
-\end{code}
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreLift where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreBinding(..), PlainCoreExpr(..))
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique)
-data CoreBinding a b
-data CoreExpr a b
-data Id
-type PlainCoreBinding = CoreBinding Id Id
-type PlainCoreExpr = CoreExpr Id Id
-data SplitUniqSupply
-data Unique
-applyBindUnlifts :: [CoreExpr Id Id -> CoreExpr Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-bindUnlift :: Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id
-isUnboxedButNotState :: UniType -> Bool
-liftCoreBindings :: SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-liftExpr :: Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkLiftedId :: Id -> Unique -> (Id, Id)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[CoreLift]{Lifts unboxed bindings and any references to them}
liftExpr,
bindUnlift,
applyBindUnlifts,
- isUnboxedButNotState,
-
- CoreBinding, PlainCoreBinding(..),
- CoreExpr, PlainCoreExpr(..),
- Id, SplitUniqSupply, Unique
+ isUnboxedButNotState
+
) where
-IMPORT_Trace
-import Pretty
+import Ubiq{-uitous-}
-import AbsPrel ( liftDataCon, mkLiftTy )
-import TysPrim ( statePrimTyCon ) -- ToDo: get from AbsPrel
-import AbsUniType
-import Id ( getIdUniType, updateIdType, mkSysLocal, isLocallyDefined )
-import IdEnv
-import Outputable
-import PlainCore
-import SplitUniq
-import Util
+import CoreSyn
+import CoreUtils ( coreExprType )
+import Id ( idType, mkSysLocal,
+ nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
+ GenId{-instances-}
+ )
+import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon )
+import TyCon ( TyCon{-instance-} )
+import Type ( maybeAppDataTyCon, eqTy )
+import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
+import Util ( zipEqual, zipWithEqual, assertPanic, panic )
infixr 9 `thenL`
+updateIdType = panic "CoreLift.updateIdType"
+isBoxedTyCon = panic "CoreLift.isBoxedTyCon"
\end{code}
%************************************************************************
@liftCoreBindings@ is the top-level interface function.
\begin{code}
-liftCoreBindings :: SplitUniqSupply -- unique supply
- -> [PlainCoreBinding] -- unlifted bindings
- -> [PlainCoreBinding] -- lifted bindings
+liftCoreBindings :: UniqSupply -- unique supply
+ -> [CoreBinding] -- unlifted bindings
+ -> [CoreBinding] -- lifted bindings
liftCoreBindings us binds
= initL (lift_top_binds binds) us
where
+ lift_top_binds [] = returnL []
+
lift_top_binds (b:bs)
= liftBindAndScope True b (
- lift_top_binds bs `thenL` \ bs ->
+ lift_top_binds bs `thenL` \ bs ->
returnL (ItsABinds bs)
- ) `thenL` \ (b, ItsABinds bs) ->
+ ) `thenL` \ (b, ItsABinds bs) ->
returnL (b:bs)
- lift_top_binds []
- = returnL []
-
-liftBindAndScope :: Bool -- top level ?
- -> PlainCoreBinding -- As yet unprocessed
- -> LiftM BindsOrExpr -- Do the scope of the bindings
- -> LiftM (PlainCoreBinding, -- Processed
+
+-----------------------
+liftBindAndScope :: Bool -- top level ?
+ -> CoreBinding -- As yet unprocessed
+ -> LiftM BindsOrExpr -- Do the scope of the bindings
+ -> LiftM (CoreBinding, -- Processed
BindsOrExpr)
liftBindAndScope top_lev bind scopeM
returnL (bind, bindsorexpr)
)
+-----------------------
+liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
-liftCoreAtom :: PlainCoreAtom -> LiftM (PlainCoreAtom, PlainCoreExpr -> PlainCoreExpr)
-
-liftCoreAtom (CoLitAtom lit)
- = returnL (CoLitAtom lit, id)
-
-liftCoreAtom (CoVarAtom v)
+liftCoreArg arg@(TyArg _) = returnL (arg, id)
+liftCoreArg arg@(UsageArg _) = returnL (arg, id)
+liftCoreArg arg@(LitArg _) = returnL (arg, id)
+liftCoreArg arg@(VarArg v)
= isLiftedId v `thenL` \ lifted ->
case lifted of
+ Nothing -> returnL (arg, id)
+
Just (lifted, unlifted) ->
- returnL (CoVarAtom unlifted, bindUnlift lifted unlifted)
- Nothing ->
- returnL (CoVarAtom v, id)
+ returnL (VarArg unlifted, bindUnlift lifted unlifted)
-liftCoreBind :: PlainCoreBinding -> LiftM PlainCoreBinding
+-----------------------
+liftCoreBind :: CoreBinding -> LiftM CoreBinding
-liftCoreBind (CoNonRec b rhs)
+liftCoreBind (NonRec b rhs)
= liftOneBind (b,rhs) `thenL` \ (b,rhs) ->
- returnL (CoNonRec b rhs)
+ returnL (NonRec b rhs)
-liftCoreBind (CoRec pairs)
- = mapL liftOneBind pairs `thenL` \ pairs ->
- returnL (CoRec pairs)
+liftCoreBind (Rec pairs)
+ = mapL liftOneBind pairs `thenL` \ pairs ->
+ returnL (Rec pairs)
+-----------------------
liftOneBind (binder,rhs)
= liftCoreExpr rhs `thenL` \ rhs ->
isLiftedId binder `thenL` \ lifted ->
Just (lifted, unlifted) ->
returnL (lifted, liftExpr unlifted rhs)
Nothing ->
- returnL (binder, rhs)
+ returnL (binder, rhs)
-liftCoreExpr :: PlainCoreExpr -> LiftM PlainCoreExpr
+-----------------------
+liftCoreExpr :: CoreExpr -> LiftM CoreExpr
-liftCoreExpr (CoVar var)
+liftCoreExpr expr@(Var var)
= isLiftedId var `thenL` \ lifted ->
case lifted of
+ Nothing -> returnL expr
Just (lifted, unlifted) ->
- returnL (bindUnlift lifted unlifted (CoVar unlifted))
- Nothing ->
- returnL (CoVar var)
+ returnL (bindUnlift lifted unlifted (Var unlifted))
-liftCoreExpr (CoLit lit)
- = returnL (CoLit lit)
+liftCoreExpr expr@(Lit lit) = returnL expr
-liftCoreExpr (CoSCC label expr)
+liftCoreExpr (SCC label expr)
= liftCoreExpr expr `thenL` \ expr ->
- returnL (CoSCC label expr)
+ returnL (SCC label expr)
-liftCoreExpr (CoLet (CoNonRec binder rhs) body) -- special case: no lifting
+liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
= liftCoreExpr rhs `thenL` \ rhs ->
liftCoreExpr body `thenL` \ body ->
- returnL (mkCoLetUnboxedToCase (CoNonRec binder rhs) body)
+ returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
-liftCoreExpr (CoLet bind body) -- general case
+liftCoreExpr (Let bind body) -- general case
= liftBindAndScope False bind (
liftCoreExpr body `thenL` \ body ->
returnL (ItsAnExpr body)
) `thenL` \ (bind, ItsAnExpr body) ->
- returnL (CoLet bind body)
+ returnL (Let bind body)
-liftCoreExpr (CoCon con tys args)
- = mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) ->
- returnL (applyBindUnlifts unlifts (CoCon con tys args))
+liftCoreExpr (Con con args)
+ = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
+ returnL (applyBindUnlifts unlifts (Con con args))
-liftCoreExpr (CoPrim op tys args)
- = mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) ->
- returnL (applyBindUnlifts unlifts (CoPrim op tys args))
+liftCoreExpr (Prim op args)
+ = mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
+ returnL (applyBindUnlifts unlifts (Prim op args))
-liftCoreExpr (CoApp fun arg)
+liftCoreExpr (App fun arg)
= lift_app fun [arg]
where
- lift_app (CoApp fun arg) args
+ lift_app (App fun arg) args
= lift_app fun (arg:args)
lift_app other_fun args
= liftCoreExpr other_fun `thenL` \ other_fun ->
- mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) ->
- returnL (applyBindUnlifts unlifts (foldl CoApp other_fun args))
+ mapAndUnzipL liftCoreArg args `thenL` \ (args, unlifts) ->
+ returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
-liftCoreExpr (CoTyApp fun ty_arg)
- = liftCoreExpr fun `thenL` \ fun ->
- returnL (CoTyApp fun ty_arg)
-
-liftCoreExpr (CoLam binders expr)
- = liftCoreExpr expr `thenL` \ expr ->
- returnL (CoLam binders expr)
-
-liftCoreExpr (CoTyLam tyvar expr)
+liftCoreExpr (Lam binder expr)
= liftCoreExpr expr `thenL` \ expr ->
- returnL (CoTyLam tyvar expr)
+ returnL (Lam binder expr)
-liftCoreExpr (CoCase scrut alts)
+liftCoreExpr (Case scrut alts)
= liftCoreExpr scrut `thenL` \ scrut ->
liftCoreAlts alts `thenL` \ alts ->
- returnL (CoCase scrut alts)
-
+ returnL (Case scrut alts)
-liftCoreAlts :: PlainCoreCaseAlternatives -> LiftM PlainCoreCaseAlternatives
+------------
+liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
-liftCoreAlts (CoAlgAlts alg_alts deflt)
+liftCoreAlts (AlgAlts alg_alts deflt)
= mapL liftAlgAlt alg_alts `thenL` \ alg_alts ->
liftDeflt deflt `thenL` \ deflt ->
- returnL (CoAlgAlts alg_alts deflt)
+ returnL (AlgAlts alg_alts deflt)
-liftCoreAlts (CoPrimAlts prim_alts deflt)
+liftCoreAlts (PrimAlts prim_alts deflt)
= mapL liftPrimAlt prim_alts `thenL` \ prim_alts ->
liftDeflt deflt `thenL` \ deflt ->
- returnL (CoPrimAlts prim_alts deflt)
-
+ returnL (PrimAlts prim_alts deflt)
+------------
liftAlgAlt (con,args,rhs)
= liftCoreExpr rhs `thenL` \ rhs ->
returnL (con,args,rhs)
+------------
liftPrimAlt (lit,rhs)
= liftCoreExpr rhs `thenL` \ rhs ->
returnL (lit,rhs)
-
-liftDeflt CoNoDefault
- = returnL CoNoDefault
-liftDeflt (CoBindDefault binder rhs)
- = liftCoreExpr rhs `thenL` \ rhs ->
- returnL (CoBindDefault binder rhs)
+------------
+liftDeflt NoDefault
+ = returnL NoDefault
+liftDeflt (BindDefault binder rhs)
+ = liftCoreExpr rhs `thenL` \ rhs ->
+ returnL (BindDefault binder rhs)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-type LiftM a = IdEnv (Id, Id) -- lifted Ids are mapped to:
- -- * lifted Id with the same Unique
- -- (top-level bindings must keep their
- -- unique (see TopLevId in Id.lhs))
- -- * unlifted version with a new Unique
- -> SplitUniqSupply -- unique supply
- -> a -- result
+type LiftM a
+ = IdEnv (Id, Id) -- lifted Ids are mapped to:
+ -- * lifted Id with the same Unique
+ -- (top-level bindings must keep their
+ -- unique (see TopLevId in Id.lhs))
+ -- * unlifted version with a new Unique
+ -> UniqSupply -- unique supply
+ -> a -- result
-data BindsOrExpr = ItsABinds [PlainCoreBinding]
- | ItsAnExpr PlainCoreExpr
+data BindsOrExpr
+ = ItsABinds [CoreBinding]
+ | ItsAnExpr CoreExpr
-initL m us
- = m nullIdEnv us
+initL m us = m nullIdEnv us
returnL :: a -> LiftM a
-returnL r idenv us
- = r
+returnL r idenv us = r
thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
thenL m k idenv s0
- = case splitUniqSupply s0 of { (s1, s2) ->
- case (m idenv s1) of { r ->
+ = case (splitUniqSupply s0) of { (s1, s2) ->
+ case (m idenv s1) of { r ->
k r idenv s2 }}
returnL ((r1:rs1),(r2:rs2))
-- liftBinders is only called for top-level or recusive case
-liftBinders :: Bool -> PlainCoreBinding -> LiftM thing -> LiftM thing
+liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
-liftBinders False (CoNonRec _ _) liftM idenv s0
- = error "CoreLift:liftBinders" -- should be caught by special case above
+liftBinders False (NonRec _ _) liftM idenv s0
+ = panic "CoreLift:liftBinders" -- should be caught by special case above
liftBinders top_lev bind liftM idenv s0
- = liftM (growIdEnvList idenv lift_map) s1
+ = liftM (growIdEnvList idenv lift_map) s2
where
- lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (getIdUniType id) ]
- (lift_uniqs, s1) = getSUniquesAndDepleted (length lift_ids) s0
- lift_map = zip lift_ids (zipWith mkLiftedId lift_ids lift_uniqs)
+ (s1, s2) = splitUniqSupply s0
+ lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
+ lift_uniqs = getUniques (length lift_ids) s1
+ lift_map = zipEqual lift_ids (zipWithEqual mkLiftedId lift_ids lift_uniqs)
-- ToDo: Give warning for recursive bindings involving unboxed values ???
-
isLiftedId :: Id -> LiftM (Maybe (Id, Id))
isLiftedId id idenv us
- | isLocallyDefined id
+ | isLocallyDefined id
= lookupIdEnv idenv id
| otherwise -- ensure all imported ids are lifted
- = if isUnboxedButNotState (getIdUniType id)
- then Just (mkLiftedId id (getSUnique us))
+ = if isUnboxedButNotState (idType id)
+ then Just (mkLiftedId id (getUnique us))
else Nothing
mkLiftedId :: Id -> Unique -> (Id,Id)
lifted_id = updateIdType id lifted_ty
unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
- unlifted_ty = getIdUniType id
+ unlifted_ty = idType id
lifted_ty = mkLiftTy unlifted_ty
-bindUnlift :: Id -> Id -> PlainCoreExpr -> PlainCoreExpr
+bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
bindUnlift vlift vunlift expr
= ASSERT (isUnboxedButNotState unlift_ty)
- ASSERT (lift_ty == mkLiftTy unlift_ty)
- CoCase (CoVar vlift)
- (CoAlgAlts [(liftDataCon, [vunlift], expr)] CoNoDefault)
+ ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty)
+ Case (Var vlift)
+ (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
where
- lift_ty = getIdUniType vlift
- unlift_ty = getIdUniType vunlift
+ lift_ty = idType vlift
+ unlift_ty = idType vunlift
-liftExpr :: Id -> PlainCoreExpr -> PlainCoreExpr
+liftExpr :: Id -> CoreExpr -> CoreExpr
liftExpr vunlift rhs
= ASSERT (isUnboxedButNotState unlift_ty)
- ASSERT (rhs_ty == unlift_ty)
- CoCase rhs (CoPrimAlts [] (CoBindDefault vunlift
- (CoCon liftDataCon [unlift_ty] [CoVarAtom vunlift])))
+ ASSERT (rhs_ty `eqTy` unlift_ty)
+ Case rhs (PrimAlts []
+ (BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift])))
where
- rhs_ty = typeOfCoreExpr rhs
- unlift_ty = getIdUniType vunlift
+ rhs_ty = coreExprType rhs
+ unlift_ty = idType vunlift
-applyBindUnlifts :: [PlainCoreExpr -> PlainCoreExpr] -> PlainCoreExpr -> PlainCoreExpr
+applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
applyBindUnlifts [] expr = expr
applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
isUnboxedButNotState ty
- = case (getUniDataTyCon_maybe ty) of
+ = case (maybeAppDataTyCon ty) of
Nothing -> False
Just (tycon, _, _) ->
not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreLint where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding, CoreExpr)
-import Id(Id)
-import Maybes(Labda)
-import PlainCore(PlainCoreBinding(..))
-import Pretty(PprStyle)
-import SrcLoc(SrcLoc)
-data CoreBinding a b
-data Id
-type PlainCoreBinding = CoreBinding Id Id
-data PprStyle
-lintCoreBindings :: PprStyle -> [Char] -> Bool -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-lintUnfolding :: SrcLoc -> CoreExpr Id Id -> Labda (CoreExpr Id Id)
-
module CoreLint (
lintCoreBindings,
- lintUnfolding,
-
- PprStyle, CoreBinding, PlainCoreBinding(..), Id
+ lintUnfolding
) where
-IMPORT_Trace
+import Ubiq
+
+import CoreSyn
-import AbsPrel ( typeOfPrimOp, mkFunTy, PrimOp(..), PrimKind
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType
import Bag
-import BasicLit ( typeOfBasicLit, BasicLit )
-import CoreSyn ( pprCoreBinding ) -- ToDo: correctly
-import Id ( getIdUniType, isNullaryDataCon, isBottomingId,
- getInstantiatedDataConSig, Id
- IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
+import Kind ( Kind{-instance-} )
+import Literal ( literalType, Literal{-instance-} )
+import Id ( idType, isBottomingId,
+ getInstantiatedDataConSig, GenId{-instances-}
)
-import Maybes
-import Outputable
-import PlainCore
+import Outputable ( Outputable(..) )
+import PprCore
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType, GenTyVar, TyCon )
import Pretty
+import PrimOp ( primOpType, PrimOp(..) )
+import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc )
-import UniqSet
-import Util
-
-infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
+import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe,
+ isPrimType,getTypeKind,instantiateTy,
+ mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
+ maybeAppDataTyCon, eqTy )
+import TyCon ( isPrimTyCon,isVisibleDataTyCon )
+import TyVar ( getTyVarKind, GenTyVar{-instances-} )
+import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
+ unionUniqSets, elementOfUniqSet, UniqSet(..) )
+import Unique ( Unique )
+import Usage ( GenUsage )
+import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
+
+infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL`
\end{code}
-Checks for
- (a) type errors
- (b) locally-defined variables used but not defined
-
-Doesn't check for out-of-scope type variables, because they can
-legitimately arise. Eg
-\begin{verbatim}
- k = /\a b -> \x::a y::b -> x
- f = /\c -> \z::c -> k c w z (error w "foo")
-\end{verbatim}
-Here \tr{w} is just a free type variable.
-
%************************************************************************
%* *
-\subsection{``lint'' for various constructs}
+\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
%* *
%************************************************************************
-@lintCoreBindings@ is the top-level interface function.
+Checks that a set of core bindings is well-formed. The PprStyle and String
+just control what we print in the event of an error. The Bool value
+indicates whether we have done any specialisation yet (in which case we do
+some extra checks).
+
+We check for
+ (a) type errors
+ (b) Out-of-scope type variables
+ (c) Out-of-scope local variables
+ (d) Ill-kinded types
+
+If we have done specialisation the we check that there are
+ (a) No top-level bindings of primitive (unboxed type)
+
+Outstanding issues:
+
+ --
+ -- Things are *not* OK if:
+ --
+ -- * Unsaturated type app before specialisation has been done;
+ --
+ -- * Oversaturated type app after specialisation (eta reduction
+ -- may well be happening...);
+ --
+ -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
+ --
\begin{code}
-lintCoreBindings :: PprStyle -> String -> Bool -> [PlainCoreBinding] -> [PlainCoreBinding]
+lintCoreBindings
+ :: PprStyle -> String -> Bool -> [CoreBinding] -> [CoreBinding]
-lintCoreBindings sty whodunnit spec_done binds
- = BSCC("CoreLint")
- case (initL (lint_binds binds) spec_done) of
+lintCoreBindings sty whoDunnit spec_done binds
+ = case (initL (lint_binds binds) spec_done) of
Nothing -> binds
- Just msg -> pprPanic "" (ppAboves [
- ppStr ("*** Core Lint Errors: in "++whodunnit++" ***"),
- msg sty,
- ppStr "*** Offending Program ***",
- ppAboves (map (pprCoreBinding sty pprBigCoreBinder pprTypedCoreBinder ppr) binds),
- ppStr "*** End of Offense ***"])
- ESCC
+ Just msg ->
+ pprPanic "" (ppAboves [
+ ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
+ msg sty,
+ ppStr "*** Offending Program ***",
+ ppAboves
+ (map (pprCoreBinding sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (ppr sty))
+ binds),
+ ppStr "*** End of Offense ***"
+ ])
where
- lint_binds :: [PlainCoreBinding] -> LintM ()
-
lint_binds [] = returnL ()
- lint_binds (bind:binds)
- = lintCoreBinds bind `thenL` \ binders ->
- addInScopeVars binders (
- lint_binds binds
- )
+ lint_binds (bind:binds)
+ = lintCoreBinding bind `thenL` \binders ->
+ addInScopeVars binders (lint_binds binds)
\end{code}
+%************************************************************************
+%* *
+\subsection[lintUnfolding]{lintUnfolding}
+%* *
+%************************************************************************
+
We use this to check all unfoldings that come in from interfaces
(it is very painful to catch errors otherwise):
+
\begin{code}
-lintUnfolding :: SrcLoc -> PlainCoreExpr -> Maybe PlainCoreExpr
+lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
lintUnfolding locn expr
- = case (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr)) True{-pretend spec done-}) of
+ = case
+ (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
+ True{-pretend spec done-})
+ of
Nothing -> Just expr
- Just msg -> pprTrace "WARNING: Discarded bad unfolding from interface:\n"
- (ppAboves [msg PprForUser,
- ppStr "*** Bad unfolding ***",
- ppr PprDebug expr,
- ppStr "*** End unfolding ***"])
- Nothing
+ Just msg ->
+ pprTrace "WARNING: Discarded bad unfolding from interface:\n"
+ (ppAboves [msg PprForUser,
+ ppStr "*** Bad unfolding ***",
+ ppr PprDebug expr,
+ ppStr "*** End unfolding ***"])
+ Nothing
\end{code}
-\begin{code}
-lintCoreAtom :: PlainCoreAtom -> LintM (Maybe UniType)
+%************************************************************************
+%* *
+\subsection[lintCoreBinding]{lintCoreBinding}
+%* *
+%************************************************************************
-lintCoreAtom (CoLitAtom lit) = returnL (Just (typeOfBasicLit lit))
-lintCoreAtom a@(CoVarAtom v)
- = checkInScope v `thenL_`
- returnL (Just (getIdUniType v))
-\end{code}
+Check a core binding, returning the list of variables bound.
\begin{code}
-lintCoreBinds :: PlainCoreBinding -> LintM [Id] -- Returns the binders
-lintCoreBinds (CoNonRec binder rhs)
- = lint_binds_help (binder,rhs) `thenL_`
- returnL [binder]
+lintCoreBinding :: CoreBinding -> LintM [Id]
+
+lintCoreBinding (NonRec binder rhs)
+ = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
-lintCoreBinds (CoRec pairs)
+lintCoreBinding (Rec pairs)
= addInScopeVars binders (
- mapL lint_binds_help pairs `thenL_`
- returnL binders
+ mapL lintSingleBinding pairs `seqL` returnL binders
)
where
binders = [b | (b,_) <- pairs]
-lint_binds_help (binder,rhs)
+lintSingleBinding (binder,rhs)
= addLoc (RhsOf binder) (
-- Check the rhs
- lintCoreExpr rhs `thenL` \ maybe_rhs_ty ->
+ lintCoreExpr rhs
+ `thenL` \maybe_ty ->
-- Check match to RHS type
- (case maybe_rhs_ty of
- Nothing -> returnL ()
- Just rhs_ty -> checkTys (getIdUniType binder)
- rhs_ty
- (mkRhsMsg binder rhs_ty)
- ) `thenL_`
-
- -- Check not isPrimType
- checkIfSpecDoneL (not (isPrimType (getIdUniType binder)))
- (mkRhsPrimMsg binder rhs)
- `thenL_`
-
- -- Check unfolding, if any
- -- Blegh. This is tricky, because the unfolding is a SimplifiableCoreExpr
- -- Give up for now
-
- returnL ()
+ (case maybe_ty of
+ Nothing -> returnL ()
+ Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
+
+ `seqL`
+ -- Check (not isPrimType)
+ checkIfSpecDoneL (not (isPrimType (idType binder)))
+ (mkRhsPrimMsg binder rhs)
+
+ -- We should check the unfolding, if any, but this is tricky because
+ -- the unfolding is a SimplifiableCoreExpr. Give up for now.
)
\end{code}
+%************************************************************************
+%* *
+\subsection[lintCoreExpr]{lintCoreExpr}
+%* *
+%************************************************************************
+
\begin{code}
-lintCoreExpr :: PlainCoreExpr -> LintM (Maybe UniType) -- Nothing if error found
+lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
-lintCoreExpr (CoVar var)
- = checkInScope var `thenL_`
- returnL (Just ty)
-{-
- case (splitForalls ty) of { (tyvars, _) ->
- if null tyvars then
- returnL (Just ty)
+lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
+lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
+lintCoreExpr (SCC _ expr) = lintCoreExpr expr
+
+lintCoreExpr (Let binds body)
+ = lintCoreBinding binds `thenL` \binders ->
+ if (null binders) then
+ lintCoreExpr body -- Can't add a new source location
else
- addErrL (mkUnappTyMsg var ty) `thenL_`
- returnL Nothing
- }
--}
- where
- ty = getIdUniType var
-
-lintCoreExpr (CoLit lit) = returnL (Just (typeOfBasicLit lit))
-lintCoreExpr (CoSCC label expr) = lintCoreExpr expr
-
-lintCoreExpr (CoLet binds body)
- = lintCoreBinds binds `thenL` \ binders ->
- ASSERT(not (null binders))
- addLoc (BodyOfLetRec binders) (
- addInScopeVars binders (
- lintCoreExpr body
- ))
-
-lintCoreExpr e@(CoCon con tys args)
- = checkTyApp con_ty tys (mkTyAppMsg e) `thenMaybeL` \ con_tau_ty ->
- -- Note: no call to checkSpecTyApp for constructor type args
- mapMaybeL lintCoreAtom args `thenL` \ maybe_arg_tys ->
- case maybe_arg_tys of
- Nothing -> returnL Nothing
- Just arg_tys -> checkFunApp con_tau_ty arg_tys (mkFunAppMsg con_tau_ty arg_tys e)
- where
- con_ty = getIdUniType con
-
-lintCoreExpr e@(CoPrim op tys args)
- = checkTyApp op_ty tys (mkTyAppMsg e) `thenMaybeL` \ op_tau_ty ->
- -- ToDo: checkSpecTyApp e tys (mkSpecTyAppMsg e) `thenMaybeL_`
- mapMaybeL lintCoreAtom args `thenL` \ maybe_arg_tys ->
- case maybe_arg_tys of
- Nothing -> returnL Nothing
- Just arg_tys -> checkFunApp op_tau_ty arg_tys (mkFunAppMsg op_tau_ty arg_tys e)
- where
- op_ty = typeOfPrimOp op
+ addLoc (BodyOfLetRec binders)
+ (addInScopeVars binders (lintCoreExpr body))
+
+lintCoreExpr e@(Con con args)
+ = lintCoreArgs False e (idType con) args
+ -- Note: we don't check for primitive types in these arguments
+
+lintCoreExpr e@(Prim op args)
+ = lintCoreArgs True e (primOpType op) args
+ -- Note: we do check for primitive types in these arguments
+
+lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
+ = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg False e ty arg
+ -- Note: we don't check for primitive types in argument to 'error'
+
+lintCoreExpr e@(App fun arg)
+ = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg True e ty arg
+ -- Note: we do check for primitive types in this argument
+
+lintCoreExpr (Lam (ValBinder var) expr)
+ = addLoc (LambdaBodyOf var)
+ (addInScopeVars [var]
+ (lintCoreExpr expr `thenMaybeL` \ty ->
+ returnL (Just (mkFunTy (idType var) ty))))
+
+lintCoreExpr (Lam (TyBinder tyvar) expr)
+ = lintCoreExpr expr `thenMaybeL` \ty ->
+ returnL (Just(mkForAllTy tyvar ty))
+ -- TODO: Should add in-scope type variable at this point
+
+lintCoreExpr e@(Case scrut alts)
+ = lintCoreExpr scrut `thenMaybeL` \ty ->
+ -- Check that it is a data type
+ case maybeAppDataTyCon ty of
+ Nothing -> addErrL (mkCaseDataConMsg e) `seqL` returnL Nothing
+ Just(tycon, _, _) -> lintCoreAlts alts ty tycon
+\end{code}
-lintCoreExpr e@(CoApp fun arg)
- = lce e []
- where
- lce (CoApp fun arg) arg_tys = lintCoreAtom arg `thenMaybeL` \ arg_ty ->
- lce fun (arg_ty:arg_tys)
+%************************************************************************
+%* *
+\subsection[lintCoreArgs]{lintCoreArgs}
+%* *
+%************************************************************************
- lce other_fun arg_tys = lintCoreExpr other_fun `thenMaybeL` \ fun_ty ->
- checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
+The boolean argument indicates whether we should flag type
+applications to primitive types as being errors.
-lintCoreExpr e@(CoTyApp fun ty_arg)
- = lce e []
- where
- lce (CoTyApp fun ty_arg) ty_args = lce fun (ty_arg:ty_args)
-
- lce other_fun ty_args = lintCoreExpr other_fun `thenMaybeL` \ fun_ty ->
- checkTyApp fun_ty ty_args (mkTyAppMsg e)
- `thenMaybeL` \ res_ty ->
- checkSpecTyApp other_fun ty_args (mkSpecTyAppMsg e)
- `thenMaybeL_`
- returnL (Just res_ty)
-
-lintCoreExpr (CoLam binders expr)
- = ASSERT (not (null binders))
- addLoc (LambdaBodyOf binders) (
- addInScopeVars binders (
- lintCoreExpr expr `thenMaybeL` \ body_ty ->
- returnL (Just (foldr (mkFunTy . getIdUniType) body_ty binders))
- ))
-
-lintCoreExpr (CoTyLam tyvar expr)
- = lintCoreExpr expr `thenMaybeL` \ body_ty ->
- case quantifyTy [tyvar] body_ty of
- (_, ty) -> returnL (Just ty) -- not worried about the TyVarTemplates that come back
-
-lintCoreExpr e@(CoCase scrut alts)
- = lintCoreExpr scrut `thenMaybeL` \ scrut_ty ->
-
- -- Check that it is a data type
- case getUniDataTyCon_maybe scrut_ty of
- Nothing -> addErrL (mkCaseDataConMsg e) `thenL_`
- returnL Nothing
- Just (tycon, _, _)
- -> lintCoreAlts alts scrut_ty tycon
-
-lintCoreAlts :: PlainCoreCaseAlternatives
- -> UniType -- Type of scrutinee
+\begin{code}
+lintCoreArgs :: Bool -> CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
+
+lintCoreArgs _ _ ty [] = returnL (Just ty)
+lintCoreArgs checkTyApp e ty (a : args)
+ = lintCoreArg checkTyApp e ty a `thenMaybeL` \ res ->
+ lintCoreArgs checkTyApp e res args
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[lintCoreArg]{lintCoreArg}
+%* *
+%************************************************************************
+
+\begin{code}
+lintCoreArg :: Bool -> CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
+
+lintCoreArg _ e ty (LitArg lit)
+ = -- Make sure function type matches argument
+ case (getFunTy_maybe ty) of
+ Just (arg,res) | (literalType lit `eqTy` arg) -> returnL(Just res)
+ _ -> addErrL (mkAppMsg ty (literalType lit) e) `seqL` returnL Nothing
+
+lintCoreArg _ e ty (VarArg v)
+ = -- Make sure variable is bound
+ checkInScope v `seqL`
+ -- Make sure function type matches argument
+ case (getFunTy_maybe ty) of
+ Just (arg,res) | (idType v `eqTy` arg) -> returnL(Just res)
+ _ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing
+
+lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
+ = -- 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
+ Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) ->
+ returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
+ _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
+
+lintCoreArg _ e ty (UsageArg u)
+ = -- TODO: Check that usage has no unbound usage variables
+ case (getForAllUsageTy ty) of
+ Just (uvar,bounds,body) ->
+ -- TODO Check argument satisfies bounds
+ returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
+ _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[lintCoreAlts]{lintCoreAlts}
+%* *
+%************************************************************************
+
+\begin{code}
+lintCoreAlts :: CoreCaseAlts
+ -> Type -- Type of scrutinee
-> TyCon -- TyCon pinned on the case
- -> LintM (Maybe UniType) -- Type of alternatives
-
-lintCoreAlts alts scrut_ty case_tycon
- = (case alts of
- CoAlgAlts alg_alts deflt ->
- chk_prim_type False case_tycon `thenL_`
- chk_non_abstract_type case_tycon `thenL_`
- mapL (lintAlgAlt scrut_ty) alg_alts `thenL` \ maybe_alt_tys ->
- lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
- returnL (maybe_deflt_ty : maybe_alt_tys)
-
- CoPrimAlts prim_alts deflt ->
- chk_prim_type True case_tycon `thenL_`
- mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
- lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
- returnL (maybe_deflt_ty : maybe_alt_tys)
- ) `thenL` \ maybe_result_tys ->
- -- Check the result types
+ -> LintM (Maybe Type) -- Type of alternatives
+
+lintCoreAlts (AlgAlts alts deflt) ty tycon
+ = panic "CoreLint.lintCoreAlts"
+{- LATER:
+ WDP: can't tell what type DNT wants here
+ = -- Check tycon is not a primitive tycon
+ addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
+ `seqL`
+ -- Check we have a non-abstract data tycon
+ addErrIfL (not (isVisibleDataTyCon tycon)) (mkCaseAbstractMsg tycon)
+ `seqL`
+ lintDeflt deflt ty
+ `thenL` \maybe_deflt_ty ->
+ mapL (lintAlgAlt ty tycon) alts
+ `thenL` \maybe_alt_tys ->
+ returnL (maybe_deflt_ty : maybe_alt_tys)
+
+lintCoreAlts (PrimAlts alts deflt) ty tycon
+ = -- Check tycon is a primitive tycon
+ addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
+ `seqL`
+ mapL (lintPrimAlt ty) alts
+ `thenL` \maybe_alt_tys ->
+ lintDeflt deflt ty
+ `thenL` \maybe_deflt_ty ->
+ returnL (maybe_deflt_ty : maybe_alt_tys)
+ -- Check the result types
+-}
+{-
+ `thenL` \ maybe_result_tys ->
case catMaybes (maybe_result_tys) of
[] -> returnL Nothing
- (first_ty:tys) -> mapL check tys `thenL_`
+ (first_ty:tys) -> mapL check tys `seqL`
returnL (Just first_ty)
where
check ty = checkTys first_ty ty (mkCaseAltMsg alts)
- where
- chk_prim_type prim_required tycon
- = if (isPrimTyCon tycon == prim_required) then
- returnL ()
- else
- addErrL (mkCasePrimMsg prim_required tycon)
-
- chk_non_abstract_type tycon
- = case (getTyConFamilySize tycon) of
- Nothing -> addErrL (mkCaseAbstractMsg tycon)
- Just _ -> returnL ()
-
+-}
lintAlgAlt scrut_ty (con,args,rhs)
- = (case getUniDataTyCon_maybe scrut_ty of
- Nothing ->
+ = (case maybeAppDataTyCon scrut_ty of
+ Nothing ->
addErrL (mkAlgAltMsg1 scrut_ty)
Just (tycon, tys_applied, cons) ->
let
(_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
in
- checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
- checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
- `thenL_`
- mapL check (arg_tys `zipEqual` args) `thenL_`
+ checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
+ checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
+ `seqL`
+ mapL check (arg_tys `zipEqual` args) `seqL`
returnL ()
- ) `thenL_`
+ ) `seqL`
addInScopeVars args (
lintCoreExpr rhs
)
where
- check (ty, arg) = checkTys ty (getIdUniType arg) (mkAlgAltMsg4 ty arg)
+ check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
-- elem: yes, the elem-list here can sometimes be long-ish,
-- but as it's use-once, probably not worth doing anything different
elem _ [] = False
elem x (y:ys) = x==y || elem x ys
-lintPrimAlt scrut_ty alt@(lit,rhs)
- = checkTys (typeOfBasicLit lit) scrut_ty (mkPrimAltMsg alt) `thenL_`
+lintPrimAlt ty alt@(lit,rhs)
+ = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
lintCoreExpr rhs
-
-lintDeflt CoNoDefault scrut_ty = returnL Nothing
-lintDeflt deflt@(CoBindDefault binder rhs) scrut_ty
- = checkTys (getIdUniType binder) scrut_ty (mkDefltMsg deflt) `thenL_`
- addInScopeVars [binder] (
- lintCoreExpr rhs
- )
-\end{code}
+lintDeflt NoDefault _ = returnL Nothing
+lintDeflt deflt@(BindDefault binder rhs) ty
+ = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
+ addInScopeVars [binder] (lintCoreExpr rhs)
+\end{code}
%************************************************************************
%* *
data LintLocInfo
= RhsOf Id -- The variable bound
- | LambdaBodyOf [Id] -- The lambda-binder
+ | LambdaBodyOf Id -- The lambda-binder
| BodyOfLetRec [Id] -- One of the binders
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
ppr sty (RhsOf v)
= ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
- ppr sty (LambdaBodyOf bs)
- = ppBesides [ppr sty (getSrcLoc (head bs)),
- ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"]
+ ppr sty (LambdaBodyOf b)
+ = ppBesides [ppr sty (getSrcLoc b),
+ ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
ppr sty (BodyOfLetRec bs)
= ppBesides [ppr sty (getSrcLoc (head bs)),
= ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
pp_binders :: PprStyle -> [Id] -> Pretty
-pp_binders sty bs
- = ppInterleave ppComma (map pp_binder bs)
- where
- pp_binder b
- = ppCat [ppr sty b, ppStr "::", ppr sty (getIdUniType b)]
+pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
+
+pp_binder :: PprStyle -> Id -> Pretty
+pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
\end{code}
\begin{code}
thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL m k spec loc scope errs
- = case m spec loc scope errs of
+ = case m spec loc scope errs of
(r, errs') -> k r spec loc scope errs'
-thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k spec loc scope errs
- = case m spec loc scope errs of
+seqL :: LintM a -> LintM b -> LintM b
+seqL m k spec loc scope errs
+ = case m spec loc scope errs of
(_, errs') -> k spec loc scope errs'
thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
(Nothing, errs2) -> (Nothing, errs2)
(Just r, errs2) -> k r spec loc scope errs2
-thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
-thenMaybeL_ m k spec loc scope errs
+seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
+seqMaybeL m k spec loc scope errs
= case m spec loc scope errs of
(Nothing, errs2) -> (Nothing, errs2)
(Just _, errs2) -> k spec loc scope errs2
checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
checkIfSpecDoneL False msg False loc scope errs = ((), errs)
+addErrIfL pred spec
+ = if pred then addErrL spec else returnL ()
+
addErrL :: ErrMsg -> LintM ()
addErrL msg spec loc scope errs = ((), addErr errs msg loc)
\end{code}
\begin{code}
-checkTyApp :: UniType
- -> [UniType]
- -> ErrMsg
- -> LintM (Maybe UniType)
-
-checkTyApp forall_ty ty_args msg spec_done loc scope errs
- = if (not spec_done && n_ty_args /= n_tyvars)
- || (spec_done && n_ty_args > n_tyvars)
- --
- -- Things are *not* OK if:
- --
- -- * Unsaturated type app before specialisation has been done;
- --
- -- * Oversaturated type app after specialisation (eta reduction
- -- may well be happening...);
- --
- -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
- --
- then (Nothing, addErr errs msg loc)
- else (Just res_ty, errs)
- where
- (tyvars, rho_ty) = splitForalls forall_ty
- n_tyvars = length tyvars
- n_ty_args = length ty_args
- leftover_tyvars = drop n_ty_args tyvars
- inst_env = tyvars `zip` ty_args
- res_ty = mkForallTy leftover_tyvars (instantiateTy inst_env rho_ty)
-\end{code}
-
-\begin{code}
-checkSpecTyApp :: PlainCoreExpr -> [UniType] -> ErrMsg -> LintM (Maybe ())
-
-checkSpecTyApp expr ty_args msg spec_done loc scope errs
- = if spec_done
- && any isUnboxedDataType ty_args
- && not (an_application_of_error expr)
- then (Nothing, addErr errs msg loc)
- else (Just (), errs)
- where
- -- always safe (but maybe unfriendly) to say "False"
- an_application_of_error (CoVar id) | isBottomingId id = True
- an_application_of_error _ = False
-\end{code}
-
-\begin{code}
-checkFunApp :: UniType -- The function type
- -> [UniType] -- The arg type(s)
- -> ErrMsg -- Error messgae
- -> LintM (Maybe UniType) -- The result type
-
-checkFunApp fun_ty arg_tys msg spec loc scope errs
- = cfa res_ty expected_arg_tys arg_tys
- where
- (expected_arg_tys, res_ty) = splitTyArgs fun_ty
-
- cfa res_ty expected [] -- Args have run out; that's fine
- = (Just (glueTyArgs expected res_ty), errs)
-
- cfa res_ty [] arg_tys -- Expected arg tys ran out first; maybe res_ty is a
- -- dictionary type which is actually a function?
- = case splitTyArgs (unDictifyTy res_ty) of
- ([], _) -> (Nothing, addErr errs msg loc) -- Too many args
- (new_expected, new_res) -> cfa new_res new_expected arg_tys
-
- cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
- = case (cmpUniType True{-properly-} expected_arg_ty arg_ty) of
- EQ_ -> cfa res_ty expected_arg_tys arg_tys
- other -> (Nothing, addErr errs msg loc) -- Arg mis-match
-\end{code}
-
-\begin{code}
checkInScope :: Id -> LintM ()
checkInScope id spec loc scope errs
= if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
- ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
+ ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
else
- ((), errs)
+ ((),errs)
-checkTys :: UniType -> UniType -> ErrMsg -> LintM ()
+checkTys :: Type -> Type -> ErrMsg -> LintM ()
checkTys ty1 ty2 msg spec loc scope errs
- = case (cmpUniType True{-properly-} ty1 ty2) of
- EQ_ -> ((), errs)
- other -> ((), addErr errs msg loc)
+ = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
\end{code}
\begin{code}
-mkCaseAltMsg :: PlainCoreCaseAlternatives -> ErrMsg
+mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
mkCaseAltMsg alts sty
- = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
+ = ppAbove (ppStr "Type of case alternatives not the same:")
(ppr sty alts)
-mkCaseDataConMsg :: PlainCoreExpr -> ErrMsg
+mkCaseDataConMsg :: CoreExpr -> ErrMsg
mkCaseDataConMsg expr sty
- = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
+ = ppAbove (ppStr "A case scrutinee not of data constructor type:")
(pp_expr sty expr)
-mkCasePrimMsg :: Bool -> TyCon -> ErrMsg
-mkCasePrimMsg True tycon sty
+mkCaseNotPrimMsg :: TyCon -> ErrMsg
+mkCaseNotPrimMsg tycon sty
= ppAbove (ppStr "A primitive case on a non-primitive type:")
(ppr sty tycon)
-mkCasePrimMsg False tycon sty
+
+mkCasePrimMsg :: TyCon -> ErrMsg
+mkCasePrimMsg tycon sty
= ppAbove (ppStr "An algebraic case on a primitive type:")
(ppr sty tycon)
= ppAbove (ppStr "An algebraic case on an abstract type:")
(ppr sty tycon)
-mkDefltMsg :: PlainCoreCaseDefault -> ErrMsg
+mkDefltMsg :: CoreCaseDefault -> ErrMsg
mkDefltMsg deflt sty
- = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
+ = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
(ppr sty deflt)
-mkFunAppMsg :: UniType -> [UniType] -> PlainCoreExpr -> ErrMsg
-mkFunAppMsg fun_ty arg_tys expr sty
- = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
- ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
- ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
+mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
+mkAppMsg fun arg expr sty
+ = ppAboves [ppStr "Argument values doesn't match argument type:",
+ ppHang (ppStr "Fun type:") 4 (ppr sty fun),
+ ppHang (ppStr "Arg type:") 4 (ppr sty arg),
+ ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
+
+mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
+mkTyAppMsg ty arg expr sty
+ = panic "mkTyAppMsg"
+{-
+ = ppAboves [ppStr "Illegal type application:",
+ ppHang (ppStr "Exp type:") 4 (ppr sty exp),
+ ppHang (ppStr "Arg type:") 4 (ppr sty arg),
ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
+-}
-mkUnappTyMsg :: Id -> UniType -> ErrMsg
-mkUnappTyMsg var ty sty
- = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
- ppBeside (ppStr "Var: ") (ppr sty var),
- ppBeside (ppStr "Its type: ") (ppr sty ty)]
+mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
+mkUsageAppMsg ty u expr sty
+ = ppAboves [ppStr "Illegal usage application:",
+ ppHang (ppStr "Exp type:") 4 (ppr sty ty),
+ ppHang (ppStr "Usage exp:") 4 (ppr sty u),
+ ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
-mkAlgAltMsg1 :: UniType -> ErrMsg
+mkAlgAltMsg1 :: Type -> ErrMsg
mkAlgAltMsg1 ty sty
= ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
(ppr sty ty)
-mkAlgAltMsg2 :: UniType -> Id -> ErrMsg
+mkAlgAltMsg2 :: Type -> Id -> ErrMsg
mkAlgAltMsg2 ty con sty
= ppAboves [
ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
ppr sty alts
]
-mkAlgAltMsg4 :: UniType -> Id -> ErrMsg
+mkAlgAltMsg4 :: Type -> Id -> ErrMsg
mkAlgAltMsg4 ty arg sty
= ppAboves [
ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
ppr sty arg
]
-mkPrimAltMsg :: (BasicLit, PlainCoreExpr) -> ErrMsg
+mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
mkPrimAltMsg alt sty
- = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
+ = ppAbove
+ (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
(ppr sty alt)
-mkRhsMsg :: Id -> UniType -> ErrMsg
+mkRhsMsg :: Id -> Type -> ErrMsg
mkRhsMsg binder ty sty
- = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
- ppr sty binder],
- ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)],
- ppCat [ppStr "Rhs type:", ppr sty ty]
- ]
+ = ppAboves
+ [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
+ ppr sty binder],
+ ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
+ ppCat [ppStr "Rhs type:", ppr sty ty]]
-mkRhsPrimMsg :: Id -> PlainCoreExpr -> ErrMsg
+mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
mkRhsPrimMsg binder rhs sty
- = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
+ = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
ppr sty binder],
- ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)]
+ ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
]
-mkTyAppMsg :: PlainCoreExpr -> ErrMsg
-mkTyAppMsg expr sty
- = ppAboves [ppStr "In a type application, either the function's type doesn't match",
- ppStr "the argument types, or an argument type is primitive:",
- pp_expr sty expr]
-
-mkSpecTyAppMsg :: PlainCoreExpr -> ErrMsg
-mkSpecTyAppMsg expr sty
- = ppAbove (ppStr "Unboxed types in a type application (after specialisation):")
- (pp_expr sty expr)
+mkSpecTyAppMsg :: CoreArg -> ErrMsg
+mkSpecTyAppMsg arg sty
+ = ppAbove
+ (ppStr "Unboxed types in a type application (after specialisation):")
+ (ppr sty arg)
+pp_expr :: PprStyle -> CoreExpr -> Pretty
pp_expr sty expr
- = pprCoreExpr sty pprBigCoreBinder pprTypedCoreBinder pprTypedCoreBinder expr
+ = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreSyn where
-import BasicLit(BasicLit)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import Id(Id)
-import Maybes(Labda)
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(Delay, PprStyle, PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-data BasicLit
-data CoreArg a = TypeArg UniType | ValArg (CoreAtom a)
-data CoreAtom a = CoVarAtom a | CoLitAtom BasicLit
-data CoreBinding a b = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)]
-data CoreCaseAlternatives a b = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b)
-data CoreCaseDefault a b = CoNoDefault | CoBindDefault a (CoreExpr a b)
-data CoreExpr a b = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b)
-data CostCentre
-data Id
-data Labda a
-data PprStyle
-data PrettyRep
-data PrimOp
-data TyCon
-data TyVar
-data UniType
-applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b
-collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b])
-decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a])
-mkCoTyApp :: CoreExpr a b -> UniType -> CoreExpr a b
-pprCoreBinding :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreBinding a b -> Int -> Bool -> PrettyRep
-pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep
-instance Outputable a => Outputable (CoreArg a)
-instance Outputable a => Outputable (CoreAtom a)
-instance (Outputable a, Outputable b) => Outputable (CoreBinding a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b)
-instance (Outputable a, Outputable b) => Outputable (CoreExpr a b)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CoreSyn]{A data type for the Haskell compiler midsection}
#include "HsVersions.h"
module CoreSyn (
- GenCoreBinding(..), GenCoreExpr(..), GenCoreAtom(..),
- GenCoreCaseAlternatives(..), GenCoreCaseDefault(..),
- pprCoreBinding, pprCoreExpr,
-
- GenCoreArg(..), applyToArgs, decomposeArgs, collectArgs,
+ GenCoreBinding(..), GenCoreExpr(..),
+ GenCoreArg(..),GenCoreBinder(..), GenCoreCaseAlts(..),
+ GenCoreCaseDefault(..),
+
+ bindersOf, pairsFromCoreBinds, rhssOfBind,
+
+ mkGenApp, mkValApp, mkTyApp, mkUseApp,
+ mkApp, mkCon, mkPrim,
+ mkValLam, mkTyLam, mkUseLam,
+ mkLam,
+ digForLambdas,
+
+ collectArgs, isValArg,
+
+ mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
+ mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
+ mkCoLetrecAny, mkCoLetrecNoUnboxed,
+
+ rhssOfAlts,
+
+ -- Common type instantiation...
+ CoreBinding(..),
+ CoreExpr(..),
+ CoreBinder(..),
+ CoreArg(..),
+ CoreCaseAlts(..),
+ CoreCaseDefault(..),
+
+ -- And not-so-common type instantiations...
+ TaggedCoreBinding(..),
+ TaggedCoreExpr(..),
+ TaggedCoreBinder(..),
+ TaggedCoreArg(..),
+ TaggedCoreCaseAlts(..),
+ TaggedCoreCaseDefault(..),
+
+ SimplifiableCoreBinding(..),
+ SimplifiableCoreExpr(..),
+ SimplifiableCoreBinder(..),
+ SimplifiableCoreArg(..),
+ SimplifiableCoreCaseAlts(..),
+ SimplifiableCoreCaseDefault(..)
-- and to make the interface self-sufficient ...
+
) where
-import PrelInfo ( PrimOp, PrimRep
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import Type ( isPrimType, pprParendUniType, TyVar, TyCon, Type
- )
-import Literal ( Literal )
-import Id ( getIdUniType, isBottomingId, Id
- IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
- )
-import Outputable
-import Pretty
+import Ubiq{-uitous-}
+
import CostCentre ( showCostCentre, CostCentre )
-import Util
+import Id ( idType )
+import Usage ( UVar(..) )
+import Util ( panic, assertPanic )
+
+isUnboxedDataType = panic "CoreSyn.isUnboxedDataType"
+--eqId :: Id -> Id -> Bool
+eqId = panic "CoreSyn.eqId"
\end{code}
%************************************************************************
| Rec [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
\end{code}
+\begin{code}
+bindersOf :: GenCoreBinding val_bdr val_occ tyvar uvar -> [val_bdr]
+
+pairsFromCoreBinds ::
+ [GenCoreBinding val_bdr val_occ tyvar uvar] ->
+ [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
+
+rhssOfBind :: GenCoreBinding val_bdr val_occ tyvar uvar -> [GenCoreExpr val_bdr val_occ tyvar uvar]
+
+bindersOf (NonRec binder _) = [binder]
+bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
+
+pairsFromCoreBinds [] = []
+pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) : pairsFromCoreBinds bs
+pairsFromCoreBinds ((Rec pairs) : bs) = pairs ++ pairsFromCoreBinds bs
+
+rhssOfBind (NonRec _ rhs) = [rhs]
+rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
+\end{code}
%************************************************************************
%* *
desugarer sets up constructors as applications of global @Vars@s.
\begin{code}
- | Con Id (GenType tyvar) [GenCoreArg val_occ tyvar uvar]
+ | Con Id [GenCoreArg val_occ tyvar uvar]
-- Saturated constructor application:
-- The constructor is a function of the form:
-- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
-- <expr> where "/\" is a type lambda and "\" the
-- regular kind; there will be "m" Types and
-- "n" bindees in the Con args.
- --
- -- The type given is the result type of the application;
- -- you can figure out the argument types from it if you want.
- | Prim PrimOp Type [GenCoreArg val_occ tyvar uvar]
+ | Prim PrimOp [GenCoreArg val_occ tyvar uvar]
-- saturated primitive operation;
-- comment on Cons applies here, too.
- -- The types work the same way
- -- (PrimitiveOps may be polymorphic).
\end{code}
Ye olde abstraction and application operators.
Case expressions (\tr{case <expr> of <List of alternatives>}): there
are really two flavours masquerading here---those for scrutinising
{\em algebraic} types and those for {\em primitive} types. Please see
-under @GenCoreCaseAlternatives@.
+under @GenCoreCaseAlts@.
\begin{code}
| Case (GenCoreExpr val_bdr val_occ tyvar uvar)
- (GenCoreCaseAlternatives val_bdr val_occ tyvar uvar)
+ (GenCoreCaseAlts val_bdr val_occ tyvar uvar)
\end{code}
A Core case expression \tr{case e of v -> ...} implies evaluation of
scoping.
\begin{code}
| Let (GenCoreBinding val_bdr val_occ tyvar uvar)
- (GenCoreExpr binder val_occ tyvar uvar)
+ (GenCoreExpr val_bdr val_occ tyvar uvar)
-- both recursive and non-.
-- The "GenCoreBinding" records that information
\end{code}
%************************************************************************
%* *
+\subsection{Core-constructing functions with checking}
+%* *
+%************************************************************************
+
+When making @Lets@, we may want to take evasive action if the thing
+being bound has unboxed type. We have different variants ...
+
+@mkCoLet(s|rec)Any@ let-binds any binding, regardless of type
+@mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings
+@mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case
+ (unboxed bindings in a letrec are still prohibited)
+
+\begin{code}
+mkCoLetAny :: GenCoreBinding val_bdr val_occ tyvar uvar
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkCoLetsAny :: [GenCoreBinding val_bdr val_occ tyvar uvar] ->
+ GenCoreExpr val_bdr val_occ tyvar uvar ->
+ GenCoreExpr val_bdr val_occ tyvar uvar
+mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkCoLetrecAny [] body = body
+mkCoLetrecAny binds body = Let (Rec binds) body
+
+mkCoLetsAny [] expr = expr
+mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
+
+mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
+mkCoLetAny bind@(NonRec binder rhs) body
+ = case body of
+ Var binder2 | binder `eqId` binder2
+ -> rhs -- hey, I have the rhs
+ other
+ -> Let bind body
+\end{code}
+
+\begin{code}
+--mkCoLetNoUnboxed ::
+-- GenCoreBinding val_bdr val_occ tyvar uvar ->
+-- GenCoreExpr val_bdr val_occ tyvar uvar ->
+-- GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkCoLetNoUnboxed bind@(Rec binds) body
+ = mkCoLetrecNoUnboxed binds body
+mkCoLetNoUnboxed bind@(NonRec binder rhs) body
+ = --ASSERT (not (isUnboxedDataType (idType binder)))
+ case body of
+ Var binder2 | binder `eqId` binder2
+ -> rhs -- hey, I have the rhs
+ other
+ -> Let bind body
+
+mkCoLetsNoUnboxed [] expr = expr
+mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
+
+--mkCoLetrecNoUnboxed :: [(Id, CoreExpr)] -- bindings
+-- -> CoreExpr -- body
+-- -> CoreExpr -- result
+
+mkCoLetrecNoUnboxed [] body = body
+mkCoLetrecNoUnboxed binds body
+ = ASSERT (all is_boxed_bind binds)
+ Let (Rec binds) body
+ where
+ is_boxed_bind (binder, rhs)
+ = (not . isUnboxedDataType . idType) binder
+\end{code}
+
+\begin{code}
+--mkCoLetUnboxedToCase ::
+-- GenCoreBinding val_bdr val_occ tyvar uvar ->
+-- GenCoreExpr val_bdr val_occ tyvar uvar ->
+-- GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkCoLetUnboxedToCase bind@(Rec binds) body
+ = mkCoLetrecNoUnboxed binds body
+mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
+ = case body of
+ Var binder2 | binder `eqId` binder2
+ -> rhs -- hey, I have the rhs
+ other
+ -> if (not (isUnboxedDataType (idType binder))) then
+ Let bind body -- boxed...
+ else
+ Case rhs -- unboxed...
+ (PrimAlts []
+ (BindDefault binder body))
+
+mkCoLetsUnboxedToCase [] expr = expr
+mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Case alternatives in @GenCoreExpr@}
%* *
%************************************************************************
\end{verbatim}
\begin{code}
-data GenCoreCaseAlternatives val_bdr val_occ tyvar uvar
-
+data GenCoreCaseAlts val_bdr val_occ tyvar uvar
= AlgAlts [(Id, -- alts: data constructor,
[val_bdr], -- constructor's parameters,
GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
-- be used in RHS.
\end{code}
+\begin{code}
+rhssOfAlts (AlgAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts]
+rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs) <- alts]
+
+rhssOfDeflt NoDefault = []
+rhssOfDeflt (BindDefault _ rhs) = [rhs]
+\end{code}
+
%************************************************************************
%* *
-\subsection[CoreSyn-arguments]{Core ``argument'' wrapper type}
+\subsection{Core binders}
%* *
%************************************************************************
\begin{code}
-data GenCoreAtom val_occ tyvar uvar
- = LitAtom Literal
- | VarAtom val_occ
- | TyAtom (GenType tyvar)
- | UsageAtom (Usage uvar)
-
+data GenCoreBinder val_bdr tyvar uvar
+ = ValBinder val_bdr
+ | TyBinder tyvar
+ | UsageBinder uvar
+\end{code}
-===+*** fix from here down ****===
-=================================
+Clump Lams together if possible.
-instance Outputable bindee => Outputable (GenCoreArg bindee) where
- ppr sty (ValArg atom) = ppr sty atom
- ppr sty (TypeArg ty) = ppr sty ty
+\begin{code}
+mkValLam :: [val_bdr]
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkTyLam :: [tyvar]
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkUseLam :: [uvar]
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkValLam binders body = foldr (Lam . ValBinder) body binders
+mkTyLam binders body = foldr (Lam . TyBinder) body binders
+mkUseLam binders body = foldr (Lam . UsageBinder) body binders
+
+mkLam :: [tyvar] -> [val_bdr] -- ToDo: could add a [uvar] arg...
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkLam tyvars valvars body
+ = mkTyLam tyvars (mkValLam valvars body)
\end{code}
+We often want to strip off leading lambdas before getting down to
+business. @digForLambdas@ is your friend.
+
+We expect (by convention) usage-, type-, and value- lambdas in that
+order.
+
\begin{code}
-applyToArgs :: GenCoreExpr val_bdr bindee
- -> [GenCoreArg bindee]
- -> GenCoreExpr val_bdr bindee
+digForLambdas ::
+ GenCoreExpr val_bdr val_occ tyvar uvar ->
+ ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
-applyToArgs fun [] = fun
-applyToArgs fun (ValArg val : args) = applyToArgs (App fun val) args
-applyToArgs fun (TypeArg ty : args) = applyToArgs (CoTyApp fun ty) args
+digForLambdas (Lam (UsageBinder u) body)
+ = let
+ (uvars, tyvars, args, final_body) = digForLambdas body
+ in
+ (u:uvars, tyvars, args, final_body)
+
+digForLambdas other
+ = let
+ (tyvars, args, body) = dig_for_tyvars other
+ in
+ ([], tyvars, args, body)
+ where
+ dig_for_tyvars (Lam (TyBinder tv) body)
+ = let
+ (tyvars, args, body2) = dig_for_tyvars body
+ in
+ (tv : tyvars, args, body2)
+
+ dig_for_tyvars body
+ = ASSERT(not (usage_lambda body))
+ let
+ (args, body2) = dig_for_valvars body
+ in
+ ([], args, body2)
+
+ ---------------------------------------
+ dig_for_valvars (Lam (ValBinder v) body)
+ = let
+ (args, body2) = dig_for_valvars body
+ in
+ (v : args, body2)
+
+ dig_for_valvars body
+ = ASSERT(not (usage_lambda body))
+ ASSERT(not (tyvar_lambda body))
+ ([], body)
+
+ ---------------------------------------
+ usage_lambda (Lam (UsageBinder _) _) = True
+ usage_lambda _ = False
+
+ tyvar_lambda (Lam (TyBinder _) _) = True
+ tyvar_lambda _ = False
\end{code}
-@decomposeArgs@ just pulls of the contiguous TypeArg-then-ValArg block
-on the front of the args. Pretty common.
+%************************************************************************
+%* *
+\subsection{Core arguments (atoms)}
+%* *
+%************************************************************************
\begin{code}
-decomposeArgs :: [GenCoreArg bindee]
- -> ([Type], [GenCoreAtom bindee], [GenCoreArg bindee])
-
-decomposeArgs [] = ([],[],[])
+data GenCoreArg val_occ tyvar uvar
+ = LitArg Literal
+ | VarArg val_occ
+ | TyArg (GenType tyvar uvar)
+ | UsageArg (GenUsage uvar)
+\end{code}
-decomposeArgs (TypeArg ty : args)
- = case (decomposeArgs args) of { (tys, vals, rest) ->
- (ty:tys, vals, rest) }
+General and specific forms:
+\begin{code}
+mkGenApp :: GenCoreExpr val_bdr val_occ tyvar uvar
+ -> [GenCoreArg val_occ tyvar uvar]
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkTyApp :: GenCoreExpr val_bdr val_occ tyvar uvar
+ -> [GenType tyvar uvar]
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkUseApp :: GenCoreExpr val_bdr val_occ tyvar uvar
+ -> [GenUsage uvar]
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+mkValApp :: GenCoreExpr val_bdr val_occ tyvar uvar
+ -> [GenCoreArg val_occ tyvar uvar] -- but we ASSERT they are LitArg or VarArg
+ -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+mkGenApp f args = foldl App f args
+mkTyApp f args = foldl (\ e a -> App e (TyArg a)) f args
+mkUseApp f args = foldl (\ e a -> App e (UsageArg a)) f args
+mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args
+
+#ifndef DEBUG
+is_Lit_or_Var a = a
+#else
+is_Lit_or_Var a
+ = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg"
+#endif
+
+isValArg (LitArg _) = True -- often used for sanity-checking
+isValArg (VarArg _) = True
+isValArg _ = False
+\end{code}
-decomposeArgs (ValArg val : args)
- = case (do_vals args) of { (vals, rest) ->
- ([], val:vals, rest) }
- where
- do_vals (ValArg val : args)
- = case (do_vals args) of { (vals, rest) ->
- (val:vals, rest) }
+\begin{code}
+mkApp fun = mk_thing (mkGenApp fun)
+mkCon con = mk_thing (Con con)
+mkPrim op = mk_thing (Prim op)
- do_vals args = ([], args)
+mk_thing thing uses tys vals
+ = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var vals)
\end{code}
@collectArgs@ takes an application expression, returning the function
and the arguments to which it is applied.
\begin{code}
-collectArgs :: GenCoreExpr val_bdr bindee
- -> (GenCoreExpr val_bdr bindee, [GenCoreArg bindee])
+collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
+ -> (GenCoreExpr val_bdr val_occ tyvar uvar,
+ [GenCoreArg val_occ tyvar uvar])
collectArgs expr
= collect expr []
where
- collect (App fun arg) args = collect fun (ValArg arg : args)
- collect (CoTyApp fun ty) args = collect fun (TypeArg ty : args)
- collect other_expr args = (other_expr, args)
+ collect (App fun arg) args = collect fun (arg : args)
+ collect fun args = (fun, args)
\end{code}
%************************************************************************
%* *
-\subsection[CoreSyn-output]{Instance declarations for output}
+\subsection{The main @Core*@ instantiation of the @GenCore*@ types}
%* *
%************************************************************************
-@pprCoreBinding@ and @pprCoreExpr@ let you give special printing
-function for ``major'' val_bdrs (those next to equal signs :-),
-``minor'' ones (lambda-bound, case-bound), and bindees. They would
-usually be called through some intermediary.
-
\begin{code}
-pprCoreBinding
- :: PprStyle
- -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
- -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
- -> (PprStyle -> bdee -> Pretty) -- to print bindees
- -> GenCoreBinding bndr bdee
- -> Pretty
-
-pprCoreBinding sty pbdr1 pbdr2 pbdee (NonRec val_bdr expr)
- = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
- 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-
-pprCoreBinding sty pbdr1 pbdr2 pbdee (Rec binds)
- = ppAboves [ifPprDebug sty (ppStr "{- Rec -}"),
- ppAboves (map ppr_bind binds),
- ifPprDebug sty (ppStr "{- end Rec -}")]
- where
- ppr_bind (val_bdr, expr)
- = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
- 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-\end{code}
-
-\begin{code}
-instance (Outputable bndr, Outputable bdee)
- => Outputable (GenCoreBinding bndr bdee) where
- ppr sty bind = pprCoreBinding sty ppr ppr ppr bind
+type CoreBinding = GenCoreBinding Id Id TyVar UVar
+type CoreExpr = GenCoreExpr Id Id TyVar UVar
+type CoreBinder = GenCoreBinder Id TyVar UVar
+type CoreArg = GenCoreArg Id TyVar UVar
-instance (Outputable bndr, Outputable bdee)
- => Outputable (GenCoreExpr bndr bdee) where
- ppr sty expr = pprCoreExpr sty ppr ppr ppr expr
-
-instance Outputable bdee => Outputable (GenCoreAtom bdee) where
- ppr sty atom = pprCoreAtom sty ppr atom
+type CoreCaseAlts = GenCoreCaseAlts Id Id TyVar UVar
+type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar
\end{code}
-\begin{code}
-pprCoreAtom
- :: PprStyle
- -> (PprStyle -> bdee -> Pretty) -- to print bindees
- -> GenCoreAtom bdee
- -> Pretty
-
-pprCoreAtom sty pbdee (LitAtom lit) = ppr sty lit
-pprCoreAtom sty pbdee (VarAtom v) = pbdee sty v
-\end{code}
+%************************************************************************
+%* *
+\subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types}
+%* *
+%************************************************************************
+Binders are ``tagged'' with a \tr{t}:
\begin{code}
-pprCoreExpr, pprParendCoreExpr
- :: PprStyle
- -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
- -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
- -> (PprStyle -> bdee -> Pretty) -- to print bindees
- -> GenCoreExpr bndr bdee
- -> Pretty
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Var name) = pbdee sty name
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Lit literal) = ppr sty literal
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con [] []) = ppr sty con
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con types args)
- = ppHang (ppBesides [ppr sty con, ppChar '!'])
- 4 (ppSep ( (map (pprParendUniType sty) types)
- ++ (map (pprCoreAtom sty pbdee) args)))
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Prim prim tys args)
- = ppHang (ppBesides [ppr sty prim, ppChar '!'])
- 4 (ppSep ( (map (pprParendUniType sty) tys)
- ++ (map (pprCoreAtom sty pbdee) args) ))
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Lam val_bdr expr)
- = ppHang (ppCat [ppStr "\\", pbdr2 sty val_bdr, ppStr "->"])
- 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar expr)
- = ppHang (ppCat [ppStr "/\\", interppSP sty (tyvar:tyvars),
- ppStr "->", pp_varss var_lists])
- 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr_after)
- where
- (tyvars, var_lists, expr_after) = collect_tyvars expr
+type Tagged t = (Id, t)
- collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, vs, e_after )
- where (tyvs, vs, e_after) = collect_tyvars e
- collect_tyvars e@(Lam _ _) = ( [], vss, e_after )
- where (vss, e_after) = collect_vars e
- collect_tyvars other_e = ( [], [], other_e )
+type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id TyVar UVar
+type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id TyVar UVar
+type TaggedCoreBinder t = GenCoreBinder (Tagged t) TyVar UVar
+type TaggedCoreArg t = GenCoreArg Id TyVar UVar
- collect_vars (Lam var e) = ([var]:varss, e_after)
- where (varss, e_after) = collect_vars e
- collect_vars other_e = ( [], other_e )
-
- pp_varss [] = ppNil
- pp_varss (vars:varss)
- = ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) vars),
- ppStr "->", pp_varss varss]
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee expr@(App fun_expr atom)
- = let
- (fun, args) = collect_args expr []
- in
- ppHang (pprParendCoreExpr sty pbdr1 pbdr2 pbdee fun)
- 4 (ppSep (map (pprCoreAtom sty pbdee) args))
- where
- collect_args (App fun arg) args = collect_args fun (arg:args)
- collect_args fun args = (fun, args)
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyApp expr ty)
- = ppHang (ppBeside pp_note (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr))
- 4 (pprParendUniType sty ty)
- where
- pp_note = ifPprShowAll sty (ppStr "{-CoTyApp-} ")
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Case expr alts)
- = ppSep [ppSep [ppStr "case", ppNest 4 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr),
- ppStr "of {"],
- ppNest 2 (pprCoreCaseAlts sty pbdr1 pbdr2 pbdee alts),
- ppStr "}"]
-
--- special cases: let ... in let ...
--- ("disgusting" SLPJ)
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
- = ppAboves [
- ppCat [ppStr "let {", pbdr1 sty val_bdr, ppEquals],
- ppNest 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
- ppStr "} in",
- pprCoreExpr sty pbdr1 pbdr2 pbdee body ]
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
- = ppAbove
- (ppHang (ppStr "let {")
- 2 (ppCat [ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
- 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
- ppStr "} in"]))
- (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-
--- general case (recursive case, too)
-pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind expr)
- = ppSep [ppHang (ppStr "let {") 2 (pprCoreBinding sty pbdr1 pbdr2 pbdee bind),
- ppHang (ppStr "} in ") 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)]
-
-pprCoreExpr sty pbdr1 pbdr2 pbdee (SCC cc expr)
- = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
- pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ]
+type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id TyVar UVar
+type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar
\end{code}
-\begin{code}
-pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Var _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
-pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Lit _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
-pprParendCoreExpr sty pbdr1 pbdr2 pbdee other_e
- = ppBesides [ppLparen, pprCoreExpr sty pbdr1 pbdr2 pbdee other_e, ppRparen]
-\end{code}
-
-\begin{code}
-instance (Outputable bndr, Outputable bdee)
- => Outputable (GenCoreCaseAlternatives bndr bdee) where
- ppr sty alts = pprCoreCaseAlts sty ppr ppr ppr alts
-\end{code}
+%************************************************************************
+%* *
+\subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types}
+%* *
+%************************************************************************
+Binders are tagged with @BinderInfo@:
\begin{code}
-pprCoreCaseAlts
- :: PprStyle
- -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
- -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
- -> (PprStyle -> bdee -> Pretty) -- to print bindees
- -> GenCoreCaseAlternatives bndr bdee
- -> Pretty
-
-pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (AlgAlts alts deflt)
- = ppAboves [ ppAboves (map ppr_alt alts),
- pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
- where
- ppr_alt (con, params, expr)
- = ppHang (ppCat [ppr_con con,
- ppInterleave ppSP (map (pbdr2 sty) params),
- ppStr "->"])
- 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
- where
- ppr_con con
- = if isOpLexeme con
- then ppBesides [ppLparen, ppr sty con, ppRparen]
- else ppr sty con
-
-pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (PrimAlts alts deflt)
- = ppAboves [ ppAboves (map ppr_alt alts),
- pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
- where
- ppr_alt (lit, expr)
- = ppHang (ppCat [ppr sty lit, ppStr "->"])
- 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
-\end{code}
+type Simplifiable = (Id, BinderInfo)
-\begin{code}
-instance (Outputable bndr, Outputable bdee)
- => Outputable (GenCoreCaseDefault bndr bdee) where
- ppr sty deflt = pprCoreCaseDefault sty ppr ppr ppr deflt
-\end{code}
+type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id TyVar UVar
+type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id TyVar UVar
+type SimplifiableCoreBinder = GenCoreBinder Simplifiable TyVar UVar
+type SimplifiableCoreArg = GenCoreArg Id TyVar UVar
-\begin{code}
-pprCoreCaseDefault
- :: PprStyle
- -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
- -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
- -> (PprStyle -> bdee -> Pretty) -- to print bindees
- -> GenCoreCaseDefault bndr bdee
- -> Pretty
-
-pprCoreCaseDefault sty pbdr1 pbdr2 pbdee NoDefault = ppNil
-
-pprCoreCaseDefault sty pbdr1 pbdr2 pbdee (BindDefault val_bdr expr)
- = ppHang (ppCat [pbdr2 sty val_bdr, ppStr "->"])
- 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
+type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id TyVar UVar
+type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreUnfold where
-import Class(Class)
-import CoreSyn(CoreExpr)
-import Id(Id)
-import Pretty(PrettyRep)
-import SimplEnv(UnfoldingGuidance)
-import TyCon(TyCon)
-calcUnfoldingGuidance :: Bool -> Int -> CoreExpr Id Id -> UnfoldingGuidance
-mentionedInUnfolding :: (a -> Id) -> CoreExpr a Id -> ([Id], [TyCon], [Class], Bool)
-pprCoreUnfolding :: CoreExpr Id Id -> Int -> Bool -> PrettyRep
-
%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
-\section[CoreUnfold]{Core-syntax functions to do with unfoldings}
+\section[CoreUnfold]{Core-syntax unfoldings}
+
+Unfoldings (which can travel across module boundaries) are in Core
+syntax (namely @CoreExpr@s).
+
+The type @UnfoldingDetails@ sits ``above'' simply-Core-expressions
+unfoldings, capturing ``higher-level'' things we know about a binding,
+usually things that the simplifier found out (e.g., ``it's a
+literal''). In the corner of a @GenForm@ unfolding, you will
+find, unsurprisingly, a Core expression.
\begin{code}
#include "HsVersions.h"
module CoreUnfold (
- calcUnfoldingGuidance,
+ UnfoldingDetails(..), UnfoldingGuidance(..), -- types
+ FormSummary(..),
- pprCoreUnfolding,
+ mkFormSummary,
+ mkGenForm,
+ mkMagicUnfolding,
+ modifyUnfoldingDetails,
+ calcUnfoldingGuidance,
mentionedInUnfolding
-
) where
-import AbsPrel ( primOpCanTriggerGC, PrimOp(..), PrimKind
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType ( getMentionedTyConsAndClassesFromUniType,
- getUniDataTyCon, getTyConFamilySize,
- pprParendUniType, Class, TyCon, TyVar,
- UniType, TauType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Bag
-import BasicLit ( isNoRepLit, isLitLitLit, BasicLit(..){-.. is for pragmas-} )
+import Ubiq
+import IdLoop -- for paranoia checking
+import PrelLoop -- for paranoia checking
+
+import Bag ( emptyBag, unitBag, unionBags, Bag )
+import BinderInfo ( oneTextualOcc, oneSafeOcc )
import CgCompInfo ( uNFOLDING_CHEAP_OP_COST,
uNFOLDING_DEAR_OP_COST,
uNFOLDING_NOREP_LIT_COST
)
-import CoreFuns ( digForLambdas, typeOfCoreExpr )
-import CoreSyn -- mostly re-exporting this stuff
-import CostCentre ( showCostCentre, noCostCentreAttached,
- currentOrSubsumedCosts, ccMentionsId, CostCentre
- )
-import Id ( pprIdInUnfolding, getIdUniType,
- whatsMentionedInId, Id, DataCon(..)
- )
-import IdInfo
-import Maybes
-import Outputable
-import PlainCore ( instCoreExpr )
+import CoreSyn
+import CoreUtils ( coreExprType )
+import CostCentre ( ccMentionsId )
+import Id ( IdSet(..), GenId{-instances-} )
+import IdInfo ( bottomIsGuaranteed )
+import Literal ( isNoRepLit, isLitLitLit )
+import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import Pretty
-import SimplEnv ( UnfoldingGuidance(..) )
-import UniqSet
-import Unique ( uniqSupply_u, UniqueSupply )
-import Util
+import PrimOp ( PrimOp(..) )
+import Type ( getAppDataTyCon )
+import UniqSet ( emptyUniqSet, singletonUniqSet, mkUniqSet,
+ unionUniqSets
+ )
+import Usage ( UVar(..) )
+import Util ( isIn, panic )
+
+manifestlyWHNF = panic "manifestlyWHNF (CoreUnfold)"
+primOpCanTriggerGC = panic "primOpCanTriggerGC (CoreUnfold)"
+getTyConFamilySize = panic "getTyConFamilySize (CoreUnfold)"
+whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
+getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@UnfoldingDetails@ and @UnfoldingGuidance@ types}
+%* *
+%************************************************************************
+
+(And @FormSummary@, too.)
+
+\begin{code}
+data UnfoldingDetails
+ = NoUnfoldingDetails
+
+ | LitForm
+ Literal
+
+ | OtherLitForm
+ [Literal] -- It is a literal, but definitely not one of these
+
+ | ConForm
+ Id -- The constructor
+ [CoreArg] -- 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
+ -- a case: case x of
+ -- c1 ... -> ...
+ -- c2 ... -> ...
+ -- v -> default-rhs
+ -- Then in default-rhs we know that v isn't c1 or c2.
+ --
+ -- NB. In the degenerate: case x of {v -> default-rhs}
+ -- x will be bound to
+ -- OtherConForm []
+ -- which captures the idea that x is eval'd but we don't
+ -- know which constructor.
+
+
+ | 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.
+
+ | MagicForm
+ Unique -- of the Id whose magic unfolding this is
+ MagicUnfoldingFun
+
+type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar
+ -- An OutExpr with occurrence info attached. This is used as
+ -- a template in GeneralForms.
+
+mkMagicUnfolding :: Unique -> UnfoldingDetails
+mkMagicUnfolding tag = MagicForm tag (mkMagicUnfoldingFun tag)
+
+data FormSummary
+ = WhnfForm -- Expression is WHNF
+ | BottomForm -- Expression is guaranteed to be bottom. We're more gung
+ -- ho about inlining such things, because it can't waste work
+ | OtherForm -- Anything else
+
+instance Outputable FormSummary where
+ ppr sty WhnfForm = ppStr "WHNF"
+ ppr sty BottomForm = ppStr "Bot"
+ ppr sty OtherForm = ppStr "Other"
+
+--???mkFormSummary :: StrictnessInfo -> GenCoreExpr bndr Id -> FormSummary
+mkFormSummary si expr
+ | manifestlyWHNF expr = WhnfForm
+ | bottomIsGuaranteed si = BottomForm
+
+ -- Chances are that the Id will be decorated with strictness info
+ -- telling that the RHS is definitely bottom. This *might* not be the
+ -- case, if it's been a while since strictness analysis, but leaving out
+ -- the test for manifestlyBottom makes things a little more efficient.
+ -- We can always put it back...
+ -- | manifestlyBottom expr = BottomForm
+
+ | otherwise = OtherForm
+\end{code}
+
+\begin{code}
+data UnfoldingGuidance
+ = UnfoldNever -- Don't do it!
+
+ | UnfoldAlways -- There is no "original" definition,
+ -- so you'd better unfold. Or: something
+ -- so cheap to unfold (e.g., 1#) that
+ -- you should do it absolutely always.
+
+ | EssentialUnfolding -- Like UnfoldAlways, but you *must* do
+ -- it absolutely always.
+ -- This is what we use for data constructors
+ -- and PrimOps, because we don't feel like
+ -- generating curried versions "just in case".
+
+ | UnfoldIfGoodArgs Int -- if "m" type args and "n" value args; and
+ Int -- those val args are manifestly data constructors
+ [Bool] -- the val-arg positions marked True
+ -- (i.e., a simplification will definitely
+ -- be possible).
+ Int -- The "size" of the unfolding; to be elaborated
+ -- later. ToDo
+
+ | BadUnfolding -- This is used by TcPragmas if the *lazy*
+ -- lintUnfolding test fails
+ -- It will never escape from the IdInfo as
+ -- it is caught by getInfo_UF and converted
+ -- to NoUnfoldingDetails
+\end{code}
+
+\begin{code}
+instance Outputable UnfoldingGuidance where
+ ppr sty UnfoldNever = ppStr "_N_"
+ ppr sty UnfoldAlways = ppStr "_ALWAYS_"
+ ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
+ ppr sty (UnfoldIfGoodArgs t v cs size)
+ = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
+ if null cs -- always print *something*
+ then ppChar 'X'
+ else ppBesides (map pp_c cs),
+ ppInt size ]
+ where
+ pp_c False = ppChar 'X'
+ pp_c True = ppChar 'C'
\end{code}
+
+%************************************************************************
+%* *
+\subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
+%* *
+%************************************************************************
+
+\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
+ -> 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}
+
+\begin{code}
+modifyUnfoldingDetails
+ :: Bool -- OK to dup
+ -> BinderInfo -- New occurrence info for the thing
+ -> UnfoldingDetails
+ -> UnfoldingDetails
+
+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
+\end{code}
+
+
%************************************************************************
%* *
\subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
calcUnfoldingGuidance
:: Bool -- True <=> OK if _scc_s appear in expr
-> Int -- bomb out if size gets bigger than this
- -> PlainCoreExpr -- expression to look at
+ -> CoreExpr -- expression to look at
-> UnfoldingGuidance
calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
= let
- (ty_binders, val_binders, body) = digForLambdas expr
+ (use_binders, ty_binders, val_binders, body) = digForLambdas expr
in
case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of
Nothing -> UnfoldNever
Just (size, cased_args)
- -> let
+ -> let
uf = UnfoldIfGoodArgs
(length ty_binders)
(length val_binders)
-> Int -- Bomb out if it gets bigger than this
-> [Id] -- Arguments; we're interested in which of these
-- get case'd
- -> PlainCoreExpr
+ -> CoreExpr
-> Maybe (Int, -- Size
[Id] -- Subset of args which are cased
)
sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
= size_up expr
where
- size_up (CoVar v) = sizeOne
- size_up (CoApp fun arg) = size_up fun `addSizeN` 1
- size_up (CoTyApp fun ty) = size_up fun -- They're free
- size_up (CoLit lit) = if isNoRepLit lit
+ size_up (Var v) = sizeOne
+ size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
+ size_up (Lit lit) = if isNoRepLit lit
then sizeN uNFOLDING_NOREP_LIT_COST
else sizeOne
- size_up (CoSCC _ (CoCon _ _ _)) = Nothing -- **** HACK *****
- size_up (CoSCC lbl body)
+ size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
+ size_up (SCC lbl body)
= if scc_s_OK then size_up body else Nothing
- size_up (CoCon con tys args) = sizeN (length args + 1)
- size_up (CoPrim op tys args) = sizeN op_cost -- NB: no charge for PrimOp args
+ size_up (Con con args) = -- 1 + # of val args
+ sizeN (1 + length [ va | va <- args, isValArg va ])
+ size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
where
op_cost = if primOpCanTriggerGC op
then uNFOLDING_DEAR_OP_COST
-- number chosen to avoid unfolding (HACK)
else uNFOLDING_CHEAP_OP_COST
- size_up (CoLam binders body) = size_up body `addSizeN` length binders
- size_up (CoTyLam tyvar body) = size_up body
+ size_up expr@(Lam _ _)
+ = let
+ (uvars, tyvars, args, body) = digForLambdas expr
+ in
+ size_up body `addSizeN` length args
- size_up (CoLet (CoNonRec binder rhs) body)
+ size_up (Let (NonRec binder rhs) body)
= size_up rhs
`addSize`
size_up body
`addSizeN`
1
- size_up (CoLet (CoRec pairs) body)
+ size_up (Let (Rec pairs) body)
= foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]
`addSize`
size_up body
`addSizeN`
length pairs
-
- size_up (CoCase scrut alts)
- = size_up_scrut scrut
+
+ size_up (Case scrut alts)
+ = size_up_scrut scrut
`addSize`
- size_up_alts (typeOfCoreExpr scrut) alts
+ size_up_alts (coreExprType scrut) alts
-- We charge for the "case" itself in "size_up_alts"
------------
- size_up_alts scrut_ty (CoAlgAlts alts deflt)
+ size_up_arg arg = if isValArg arg then sizeOne else sizeZero{-it's free-}
+
+ ------------
+ size_up_alts scrut_ty (AlgAlts alts deflt)
= foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
`addSizeN`
(case (getTyConFamilySize tycon) of { Just n -> n })
size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
- (tycon, _, _) = getUniDataTyCon scrut_ty
-
+ (tycon, _, _) = getAppDataTyCon scrut_ty
- size_up_alts _ (CoPrimAlts alts deflt)
- = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
+ size_up_alts _ (PrimAlts alts deflt)
+ = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
-- *no charge* for a primitive "case"!
where
size_prim_alt (lit,rhs) = size_up rhs
------------
- size_up_deflt CoNoDefault = sizeZero
- size_up_deflt (CoBindDefault binder rhs) = size_up rhs
+ size_up_deflt NoDefault = sizeZero
+ size_up_deflt (BindDefault binder rhs) = size_up rhs
------------
-- Scrutinees. There are two things going on here.
-- First, we want to record if we're case'ing an argument
-- Second, we want to charge nothing for the srutinee if it's just
-- a variable. That way wrapper-like things look cheap.
- size_up_scrut (CoVar v) | v `is_elem` args = Just (0, [v])
+ size_up_scrut (Var v) | v `is_elem` args = Just (0, [v])
| otherwise = Just (0, [])
size_up_scrut other = size_up other
+ is_elem :: Id -> [Id] -> Bool
is_elem = isIn "size_up_scrut"
------------
addSizeN Nothing _ = Nothing
addSizeN (Just (n, xs)) m
| tot < bOMB_OUT_SIZE = Just (tot, xs)
- | otherwise = -- pprTrace "bomb1:" (ppCat [ppInt tot, ppInt bOMB_OUT_SIZE, ppr PprDebug expr])
- Nothing
+ | otherwise = Nothing
where
tot = n+m
addSize _ Nothing = Nothing
addSize (Just (n, xs)) (Just (m, ys))
| tot < bOMB_OUT_SIZE = Just (tot, xys)
- | otherwise = -- pprTrace "bomb2:" (ppCat [ppInt tot, ppInt bOMB_OUT_SIZE, ppr PprDebug expr])
- Nothing
+ | otherwise = Nothing
where
tot = n+m
xys = xs ++ ys
%************************************************************************
\begin{code}
+{-
mentionedInUnfolding
:: (bndr -> Id) -- so we can get Ids out of binders
- -> CoreExpr bndr Id -- input expression
- -> ([Id], [TyCon], [Class],
+ -> GenCoreExpr bndr Id -- input expression
+ -> (Bag Id, Bag TyCon, Bag Class,
-- what we found mentioned in the expr
Bool -- True <=> mentions a ``litlit''-ish thing
-- (the guy on the other side of an interface
-- may not be able to handle it)
)
+-}
mentionedInUnfolding get_id expr
= case (ment_expr expr no_in_scopes get_id (emptyBag, emptyBag, emptyBag, False)) of
(_, (ids_bag, tcs_bag, clss_bag, has_litlit)) ->
- (bagToList ids_bag, bagToList tcs_bag, bagToList clss_bag, has_litlit)
+ (ids_bag, tcs_bag, clss_bag, has_litlit)
\end{code}
\begin{code}
-ment_expr :: CoreExpr bndr Id -> UnfoldM bndr ()
+--ment_expr :: GenCoreExpr bndr Id -> UnfoldM bndr ()
-ment_expr (CoVar v) = consider_Id v
-ment_expr (CoLit l) = consider_lit l
+ment_expr (Var v) = consider_Id v
+ment_expr (Lit l) = consider_lit l
-ment_expr (CoLam bs body)
- = extractIdsUf bs `thenUf` \ bs_ids ->
+ment_expr expr@(Lam _ _)
+ = let
+ (uvars, tyvars, args, body) = digForLambdas expr
+ in
+ extractIdsUf args `thenUf` \ bs_ids ->
addInScopesUf bs_ids (
-- this considering is just to extract any mentioned types/classes
mapUf consider_Id bs_ids `thenUf_`
ment_expr body
)
-ment_expr (CoTyLam _ body) = ment_expr body
-
-ment_expr (CoApp fun arg)
+ment_expr (App fun arg)
= ment_expr fun `thenUf_`
- ment_atom arg
-
-ment_expr (CoTyApp expr ty)
- = ment_ty ty `thenUf_`
- ment_expr expr
+ ment_arg arg
-ment_expr (CoCon c ts as)
+ment_expr (Con c as)
= consider_Id c `thenUf_`
- mapUf ment_ty ts `thenUf_`
- mapUf ment_atom as `thenUf_`
+ mapUf ment_arg as `thenUf_`
returnUf ()
-ment_expr (CoPrim op ts as)
+ment_expr (Prim op as)
= ment_op op `thenUf_`
- mapUf ment_ty ts `thenUf_`
- mapUf ment_atom as `thenUf_`
+ mapUf ment_arg as `thenUf_`
returnUf ()
where
ment_op (CCallOp str is_asm may_gc arg_tys res_ty)
ment_ty res_ty
ment_op other_op = returnUf ()
-ment_expr (CoCase scrutinee alts)
+ment_expr (Case scrutinee alts)
= ment_expr scrutinee `thenUf_`
ment_alts alts
-ment_expr (CoLet (CoNonRec bind rhs) body)
+ment_expr (Let (NonRec bind rhs) body)
= ment_expr rhs `thenUf_`
extractIdsUf [bind] `thenUf` \ bi@[bind_id] ->
addInScopesUf bi (
ment_expr body `thenUf_`
consider_Id bind_id )
-ment_expr (CoLet (CoRec pairs) body)
+ment_expr (Let (Rec pairs) body)
= let
binders = map fst pairs
rhss = map snd pairs
in
extractIdsUf binders `thenUf` \ binder_ids ->
addInScopesUf binder_ids (
- mapUf ment_expr rhss `thenUf_`
+ mapUf ment_expr rhss `thenUf_`
mapUf consider_Id binder_ids `thenUf_`
- ment_expr body )
+ ment_expr body )
-ment_expr (CoSCC cc expr)
+ment_expr (SCC cc expr)
= (case (ccMentionsId cc) of
Just id -> consider_Id id
Nothing -> returnUf ()
-------------
ment_ty ty
= let
- (tycons, clss) = getMentionedTyConsAndClassesFromUniType ty
+ (tycons, clss) = getMentionedTyConsAndClassesFromType ty
in
addToMentionedTyConsUf tycons `thenUf_`
addToMentionedClassesUf clss
-------------
-ment_alts alg_alts@(CoAlgAlts alts deflt)
+ment_alts alg_alts@(AlgAlts alts deflt)
= mapUf ment_alt alts `thenUf_`
ment_deflt deflt
where
mapUf consider_Id param_ids `thenUf_`
ment_expr rhs )
-ment_alts (CoPrimAlts alts deflt)
+ment_alts (PrimAlts alts deflt)
= mapUf ment_alt alts `thenUf_`
ment_deflt deflt
where
ment_alt alt@(lit, rhs) = ment_expr rhs
----------------
-ment_deflt CoNoDefault
+ment_deflt NoDefault
= returnUf ()
-ment_deflt d@(CoBindDefault b rhs)
+ment_deflt d@(BindDefault b rhs)
= extractIdsUf [b] `thenUf` \ bi@[b_id] ->
addInScopesUf bi (
consider_Id b_id `thenUf_`
ment_expr rhs )
-----------
-ment_atom (CoVarAtom v) = consider_Id v
-ment_atom (CoLitAtom l) = consider_lit l
+ment_arg (VarArg v) = consider_Id v
+ment_arg (LitArg l) = consider_lit l
+ment_arg (TyArg ty) = ment_ty ty
+ment_arg (UsageArg _) = returnUf ()
-----------
consider_lit lit
Printing Core-expression unfoldings is sufficiently delicate that we
give it its own function.
\begin{code}
+{- OLD:
pprCoreUnfolding
- :: PlainCoreExpr
+ :: CoreExpr
-> Pretty
pprCoreUnfolding expr
\end{code}
\begin{code}
-ppr_uf_Expr in_scopes (CoVar v) = pprIdInUnfolding in_scopes v
-ppr_uf_Expr in_scopes (CoLit l) = ppr ppr_Unfolding l
+ppr_uf_Expr in_scopes (Var v) = pprIdInUnfolding in_scopes v
+ppr_uf_Expr in_scopes (Lit l) = ppr ppr_Unfolding l
-ppr_uf_Expr in_scopes (CoCon c ts as)
+ppr_uf_Expr in_scopes (Con c as)
= ppBesides [ppPStr SLIT("_!_ "), pprIdInUnfolding no_in_scopes c, ppSP,
ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
-ppr_uf_Expr in_scopes (CoPrim op ts as)
+ppr_uf_Expr in_scopes (Prim op as)
= ppBesides [ppPStr SLIT("_#_ "), ppr ppr_Unfolding op, ppSP,
ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
-ppr_uf_Expr in_scopes (CoLam binders body)
- = ppCat [ppChar '\\', ppIntersperse ppSP (map ppr_uf_Binder binders),
- ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add_some` binders) body]
+ppr_uf_Expr in_scopes (Lam binder body)
+ = ppCat [ppChar '\\', ppr_uf_Binder binder,
+ ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add1` binder) body]
ppr_uf_Expr in_scopes (CoTyLam tyvar expr)
= ppCat [ppPStr SLIT("_/\\_"), interppSP ppr_Unfolding (tyvar:tyvars), ppStr "->",
where (tyvs, e_after) = collect_tyvars e
collect_tyvars other_e = ( [], other_e )
-ppr_uf_Expr in_scopes expr@(CoApp fun_expr atom)
+ppr_uf_Expr in_scopes expr@(App fun_expr atom)
= let
(fun, args) = collect_args expr []
in
ppCat [ppPStr SLIT("_APP_ "), ppr_uf_Expr in_scopes fun, ppLbrack,
ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) args), ppRbrack]
where
- collect_args (CoApp fun arg) args = collect_args fun (arg:args)
+ collect_args (App fun arg) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
ppr_uf_Expr in_scopes (CoTyApp expr ty)
= ppCat [ppPStr SLIT("_TYAPP_ "), ppr_uf_Expr in_scopes expr,
ppChar '{', pprParendUniType ppr_Unfolding ty, ppChar '}']
-ppr_uf_Expr in_scopes (CoCase scrutinee alts)
+ppr_uf_Expr in_scopes (Case scrutinee alts)
= ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {",
pp_alts alts, ppChar '}']
where
- pp_alts (CoAlgAlts alts deflt)
+ pp_alts (AlgAlts alts deflt)
= ppCat [ppPStr SLIT("_ALG_"), ppCat (map pp_alg alts), pp_deflt deflt]
- pp_alts (CoPrimAlts alts deflt)
+ pp_alts (PrimAlts alts deflt)
= ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt]
pp_alg (con, params, rhs)
= ppBesides [ppr ppr_Unfolding lit,
ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi]
- pp_deflt CoNoDefault = ppPStr SLIT("_NO_DEFLT_")
- pp_deflt (CoBindDefault binder rhs)
+ pp_deflt NoDefault = ppPStr SLIT("_NO_DEFLT_")
+ pp_deflt (BindDefault binder rhs)
= ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "),
ppr_uf_Expr (in_scopes `add1` binder) rhs]
-ppr_uf_Expr in_scopes (CoLet (CoNonRec binder rhs) body)
+ppr_uf_Expr in_scopes (Let (NonRec binder rhs) body)
= ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs,
ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body]
-ppr_uf_Expr in_scopes (CoLet (CoRec pairs) body)
+ppr_uf_Expr in_scopes (Let (Rec pairs) body)
= ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs),
ppStr "} in ", ppr_uf_Expr new_in_scopes body]
where
pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs]
-ppr_uf_Expr in_scopes (CoSCC cc body)
+ppr_uf_Expr in_scopes (SCC cc body)
= ASSERT(not (noCostCentreAttached cc))
ASSERT(not (currentOrSubsumedCosts cc))
ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ", ppr_uf_Expr in_scopes body]
ppr_uf_Binder :: Id -> Pretty
ppr_uf_Binder v
= ppBesides [ppLparen, pprIdInUnfolding (singletonUniqSet v) v, ppPStr SLIT(" :: "),
- ppr ppr_Unfolding (getIdUniType v), ppRparen]
+ ppr ppr_Unfolding (idType v), ppRparen]
-ppr_uf_Atom in_scopes (CoLitAtom l) = ppr ppr_Unfolding l
-ppr_uf_Atom in_scopes (CoVarAtom v) = pprIdInUnfolding in_scopes v
+ppr_uf_Atom in_scopes (LitArg l) = ppr ppr_Unfolding l
+ppr_uf_Atom in_scopes (VarArg v) = pprIdInUnfolding in_scopes v
+END OLD -}
\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[CoreUtils]{Utility functions on @Core@ syntax}
+
+\begin{code}
+#include "HsVersions.h"
+
+module CoreUtils (
+ coreExprType, coreAltsType,
+
+ substCoreExpr
+
+ , mkCoreIfThenElse
+ , mkErrorApp, escErrorMsg
+ , argToExpr
+ , unTagBinders, unTagBindersAlts
+{- exprSmallEnoughToDup,
+ manifestlyWHNF, manifestlyBottom,
+ coreExprArity,
+ isWrapperFor,
+ maybeErrorApp,
+ nonErrorRHSs,
+ squashableDictishCcExpr,
+
+-} ) where
+
+import Ubiq
+import IdLoop -- for pananoia-checking purposes
+
+import CoreSyn
+
+import CostCentre ( isDictCC )
+import Id ( idType, mkSysLocal,
+ addOneToIdEnv, growIdEnvList, lookupIdEnv,
+ isNullIdEnv, IdEnv(..),
+ GenId{-instances-}
+ )
+import Literal ( literalType, isNoRepLit, Literal(..) )
+import Maybes ( catMaybes )
+import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
+import Pretty ( ppAboves )
+import PrelInfo ( trueDataCon, falseDataCon,
+ augmentId, buildId,
+ pAT_ERROR_ID
+ )
+import PrimOp ( primOpType, PrimOp(..) )
+import SrcLoc ( mkUnknownSrcLoc )
+import TyVar ( isNullTyVarEnv, TyVarEnv(..), GenTyVar{-instances-} )
+import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy,
+ getFunTy_maybe, applyTy, splitSigmaTy
+ )
+import Unique ( Unique{-instances-} )
+import UniqSupply ( initUs, returnUs, thenUs,
+ mapUs, mapAndUnzipUs,
+ UniqSM(..), UniqSupply
+ )
+import Util ( zipEqual, panic, pprPanic, assertPanic )
+
+type TypeEnv = TyVarEnv Type
+applyUsage = panic "CoreUtils.applyUsage:ToDo"
+dup_binder = panic "CoreUtils.dup_binder"
+applyTypeEnvToTy = panic "CoreUtils.applyTypeEnvToTy"
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Find the type of a Core atom/expression}
+%* *
+%************************************************************************
+
+\begin{code}
+coreExprType :: CoreExpr -> Type
+
+coreExprType (Var var) = idType var
+coreExprType (Lit lit) = literalType lit
+
+coreExprType (Let _ body) = coreExprType body
+coreExprType (SCC _ expr) = coreExprType expr
+coreExprType (Case _ alts) = coreAltsType alts
+
+-- a Con is a fully-saturated application of a data constructor
+-- a Prim is <ditto> of a PrimOp
+
+coreExprType (Con con args) = applyTypeToArgs (idType con) args
+coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
+
+coreExprType (Lam (ValBinder binder) expr)
+ = mkFunTys [idType binder] (coreExprType expr)
+
+coreExprType (Lam (TyBinder tyvar) expr)
+ = mkForAllTy tyvar (coreExprType expr)
+
+coreExprType (Lam (UsageBinder uvar) expr)
+ = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
+
+coreExprType (App expr (TyArg ty))
+ = applyTy (coreExprType expr) ty
+
+coreExprType (App expr (UsageArg use))
+ = applyUsage (coreExprType expr) use
+
+coreExprType (App expr val_arg)
+ = ASSERT(isValArg val_arg)
+ let
+ fun_ty = coreExprType expr
+ in
+ case (getFunTy_maybe fun_ty) of
+ Just (_, result_ty) -> result_ty
+#ifdef DEBUG
+ Nothing -> pprPanic "coreExprType:\n"
+ (ppAboves [ppr PprDebug fun_ty,
+ ppr PprShowAll (App expr val_arg)])
+#endif
+\end{code}
+
+\begin{code}
+coreAltsType :: CoreCaseAlts -> Type
+
+coreAltsType (AlgAlts [] deflt) = default_ty deflt
+coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
+
+coreAltsType (PrimAlts [] deflt) = default_ty deflt
+coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
+
+default_ty NoDefault = panic "coreExprType:Case:default_ty"
+default_ty (BindDefault _ rhs) = coreExprType rhs
+\end{code}
+
+\begin{code}
+applyTypeToArgs = panic "applyTypeToArgs"
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Routines to manufacture bits of @CoreExpr@}
+%* *
+%************************************************************************
+
+\begin{code}
+mkCoreIfThenElse (Var bool) then_expr else_expr
+ | bool == trueDataCon = then_expr
+ | bool == falseDataCon = else_expr
+
+mkCoreIfThenElse guard then_expr else_expr
+ = Case guard
+ (AlgAlts [ (trueDataCon, [], then_expr),
+ (falseDataCon, [], else_expr) ]
+ NoDefault )
+\end{code}
+
+\begin{code}
+mkErrorApp :: Type -> Id -> String -> CoreExpr
+
+mkErrorApp ty str_var error_msg
+ = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
+ mkApp (Var pAT_ERROR_ID) [] [ty] [VarArg str_var])
+
+escErrorMsg [] = []
+escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
+escErrorMsg (x:xs) = x : escErrorMsg xs
+\end{code}
+
+For making @Apps@ and @Lets@, we must take appropriate evasive
+action if the thing being bound has unboxed type. @mkCoApp@ requires
+a name supply to do its work. Other-monad code will call @mkCoApp@
+through its own interface function (e.g., the desugarer uses
+@mkCoAppDs@).
+
+@mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
+arguments-must-be-atoms constraint.
+
+\begin{code}
+{- LATER:
+--mkCoApp :: CoreExpr -> CoreExpr -> UniqSM CoreExpr
+
+mkCoApp e1 (Var v) = returnUs (App e1 (VarArg v))
+mkCoApp e1 (Lit l) = returnUs (App e1 (LitArg l))
+mkCoApp e1 e2
+ = let
+ e2_ty = coreExprType e2
+ in
+ panic "getUnique" `thenUs` \ uniq ->
+ let
+ new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
+ in
+ returnUs (
+ mkCoLetUnboxedToCase (NonRec new_var e2)
+ (App e1 (VarArg new_var))
+ )
+-}
+\end{code}
+
+\begin{code}
+{-LATER
+mkCoCon :: Id -> [CoreExpr] -> UniqSM CoreExpr
+mkCoPrim :: PrimOp -> [CoreExpr] -> UniqSM CoreExpr
+
+mkCoCon con args = mkCoThing (Con con) args
+mkCoPrim op args = mkCoThing (Prim op) args
+
+mkCoThing thing arg_exprs
+ = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
+ returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
+ where
+ expr_to_arg :: CoreExpr
+ -> UniqSM (CoreArg, Maybe CoreBinding)
+
+ expr_to_arg (Var v) = returnUs (VarArg v, Nothing)
+ expr_to_arg (Lit l) = returnUs (LitArg l, Nothing)
+ expr_to_arg other_expr
+ = let
+ e_ty = coreExprType other_expr
+ in
+ panic "getUnique" `thenUs` \ uniq ->
+ let
+ new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
+ new_atom = VarArg new_var
+ in
+ returnUs (new_atom, Just (NonRec new_var other_expr))
+-}
+\end{code}
+
+\begin{code}
+argToExpr ::
+ GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
+
+argToExpr (VarArg v) = Var v
+argToExpr (LitArg lit) = Lit lit
+\end{code}
+
+\begin{code}
+{- LATER:
+--mkCoApps ::
+-- GenCoreExpr val_bdr val_occ tyvar uvar ->
+-- [GenCoreExpr val_bdr val_occ tyvar uvar] ->
+-- UniqSM(GenCoreExpr val_bdr val_occ tyvar uvar)
+
+mkCoApps fun [] = returnUs fun
+mkCoApps fun (arg:args)
+ = mkCoApp fun arg `thenUs` \ new_fun ->
+ mkCoApps new_fun args
+\end{code}
+
+\begin{code}
+exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool
+
+exprSmallEnoughToDup (Con _ _ _) = True -- Could check # of args
+exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op) -- Could check # of args
+exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
+
+exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
+ = case (collectArgs expr) of { (fun, args) ->
+ case fun of
+ Var v -> v /= buildId
+ && v /= augmentId
+ && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
+ _ -> False
+ }
+\end{code}
+Question (ADR): What is the above used for? Is a _ccall_ really small
+enough?
+
+@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
+it is obviously in weak head normal form. It isn't a disaster if it
+errs on the conservative side (returning \tr{False})---I've probably
+left something out... [WDP]
+
+\begin{code}
+manifestlyWHNF :: GenCoreExpr bndr Id -> Bool
+
+manifestlyWHNF (Var _) = True
+manifestlyWHNF (Lit _) = True
+manifestlyWHNF (Con _ _ _) = True -- ToDo: anything for Prim?
+manifestlyWHNF (Lam _ _) = True
+manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
+manifestlyWHNF (SCC _ e) = manifestlyWHNF e
+manifestlyWHNF (Let _ e) = False
+manifestlyWHNF (Case _ _) = False
+
+manifestlyWHNF other_expr -- look for manifest partial application
+ = case (collectArgs other_expr) of { (fun, args) ->
+ case fun of
+ Var f -> let
+ num_val_args = length [ a | (ValArg a) <- args ]
+ in
+ num_val_args == 0 || -- Just a type application of
+ -- a variable (f t1 t2 t3)
+ -- counts as WHNF
+ case (arityMaybe (getIdArity f)) of
+ Nothing -> False
+ Just arity -> num_val_args < arity
+
+ _ -> False
+ }
+\end{code}
+
+@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
+it is obviously bottom, that is, it will certainly return bottom at
+some point. It isn't a disaster if it errs on the conservative side
+(returning \tr{False}).
+
+\begin{code}
+manifestlyBottom :: GenCoreExpr bndr Id -> Bool
+
+manifestlyBottom (Var v) = isBottomingId v
+manifestlyBottom (Lit _) = False
+manifestlyBottom (Con _ _ _) = False
+manifestlyBottom (Prim _ _ _)= False
+manifestlyBottom (Lam _ _) = False -- we do not assume \x.bottom == bottom. should we? ToDo
+manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
+manifestlyBottom (SCC _ e) = manifestlyBottom e
+manifestlyBottom (Let _ e) = manifestlyBottom e
+
+manifestlyBottom (Case e a)
+ = manifestlyBottom e
+ || (case a of
+ AlgAlts alts def -> all mbalg alts && mbdef def
+ PrimAlts alts def -> all mbprim alts && mbdef def
+ )
+ where
+ mbalg (_,_,e') = manifestlyBottom e'
+
+ mbprim (_,e') = manifestlyBottom e'
+
+ mbdef NoDefault = True
+ mbdef (BindDefault _ e') = manifestlyBottom e'
+
+manifestlyBottom other_expr -- look for manifest partial application
+ = case (collectArgs other_expr) of { (fun, args) ->
+ case fun of
+ Var f | isBottomingId f -> True -- Application of a function which
+ -- always gives bottom; we treat this as
+ -- a WHNF, because it certainly doesn't
+ -- need to be shared!
+ _ -> False
+ }
+\end{code}
+
+\begin{code}
+coreExprArity
+ :: (Id -> Maybe (GenCoreExpr bndr Id))
+ -> GenCoreExpr bndr Id
+ -> Int
+coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
+coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
+coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
+coreExprArity f (CoTyApp expr _) = coreExprArity f expr
+coreExprArity f (Var v) = max further info
+ where
+ further
+ = case f v of
+ Nothing -> 0
+ Just expr -> coreExprArity f expr
+ info = case (arityMaybe (getIdArity v)) of
+ Nothing -> 0
+ Just arity -> arity
+coreExprArity f _ = 0
+\end{code}
+
+@isWrapperFor@: we want to see exactly:
+\begin{verbatim}
+/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
+\end{verbatim}
+
+Probably a little too HACKY [WDP].
+
+\begin{code}
+isWrapperFor :: CoreExpr -> Id -> Bool
+
+expr `isWrapperFor` var
+ = case (digForLambdas expr) of { (_, _, args, body) -> -- lambdas off the front
+ unravel_casing args body
+ --NO, THANKS: && not (null args)
+ }
+ where
+ var's_worker = getWorkerId (getIdStrictness var)
+
+ is_elem = isIn "isWrapperFor"
+
+ --------------
+ unravel_casing case_ables (Case scrut alts)
+ = case (collectArgs scrut) of { (fun, args) ->
+ case fun of
+ Var scrut_var -> let
+ answer =
+ scrut_var /= var && all (doesn't_mention var) args
+ && scrut_var `is_elem` case_ables
+ && unravel_alts case_ables alts
+ in
+ answer
+
+ _ -> False
+ }
+
+ unravel_casing case_ables other_expr
+ = case (collectArgs other_expr) of { (fun, args) ->
+ case fun of
+ Var wrkr -> let
+ answer =
+ -- DOESN'T WORK: wrkr == var's_worker
+ wrkr /= var
+ && isWorkerId wrkr
+ && all (doesn't_mention var) args
+ && all (only_from case_ables) args
+ in
+ answer
+
+ _ -> False
+ }
+
+ --------------
+ unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
+ = unravel_casing (params ++ case_ables) rhs
+ unravel_alts case_ables other = False
+
+ -------------------------
+ doesn't_mention var (ValArg (VarArg v)) = v /= var
+ doesn't_mention var other = True
+
+ -------------------------
+ only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
+ only_from case_ables other = True
+-}
+\end{code}
+
+All the following functions operate on binders, perform a uniform
+transformation on them; ie. the function @(\ x -> (x,False))@
+annotates all binders with False.
+
+\begin{code}
+unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
+unTagBinders expr = bop_expr fst expr
+
+unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
+unTagBindersAlts alts = bop_alts fst alts
+\end{code}
+
+\begin{code}
+bop_expr :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
+
+bop_expr f (Var b) = Var b
+bop_expr f (Lit lit) = Lit lit
+bop_expr f (Con con args) = Con con args
+bop_expr f (Prim op args) = Prim op args
+bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
+bop_expr f (App expr arg) = App (bop_expr f expr) arg
+bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
+bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
+bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
+
+bop_binder f (ValBinder v) = ValBinder (f v)
+bop_binder f (TyBinder t) = TyBinder t
+bop_binder f (UsageBinder u) = UsageBinder u
+
+bop_bind f (NonRec b e) = NonRec (f b) (bop_expr f e)
+bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
+
+bop_alts f (AlgAlts alts deflt)
+ = AlgAlts [ (con, [f b | b <- binders], bop_expr f e)
+ | (con, binders, e) <- alts ]
+ (bop_deflt f deflt)
+
+bop_alts f (PrimAlts alts deflt)
+ = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
+ (bop_deflt f deflt)
+
+bop_deflt f (NoDefault) = NoDefault
+bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
+\end{code}
+
+OLD (but left here because of the nice example): @singleAlt@ checks
+whether a bunch of case alternatives is actually just one alternative.
+It specifically {\em ignores} alternatives which consist of just a
+call to @error@, because they won't result in any code duplication.
+
+Example:
+\begin{verbatim}
+ case (case <something> of
+ True -> <rhs>
+ False -> error "Foo") of
+ <alts>
+
+===>
+
+ case <something> of
+ True -> case <rhs> of
+ <alts>
+ False -> case error "Foo" of
+ <alts>
+
+===>
+
+ case <something> of
+ True -> case <rhs> of
+ <alts>
+ False -> error "Foo"
+\end{verbatim}
+Notice that the \tr{<alts>} don't get duplicated.
+
+\begin{code}
+{- LATER:
+nonErrorRHSs :: GenCoreCaseAlts binder Id -> [GenCoreExpr binder Id]
+
+nonErrorRHSs alts = filter not_error_app (find_rhss alts)
+ where
+ find_rhss (AlgAlts alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
+ find_rhss (PrimAlts alts deflt) = [rhs | (_,rhs) <- alts] ++ deflt_rhs deflt
+
+ deflt_rhs NoDefault = []
+ deflt_rhs (BindDefault _ rhs) = [rhs]
+
+ not_error_app rhs = case maybeErrorApp rhs Nothing of
+ Just _ -> False
+ Nothing -> True
+\end{code}
+
+maybeErrorApp checkes whether an expression is of the form
+
+ error ty args
+
+If so, it returns
+
+ Just (error ty' args)
+
+where ty' is supplied as an argument to maybeErrorApp.
+
+Here's where it is useful:
+
+ case (error ty "Foo" e1 e2) of <alts>
+ ===>
+ error ty' "Foo"
+
+where ty' is the type of any of the alternatives.
+You might think this never occurs, but see the comments on
+the definition of @singleAlt@.
+
+Note: we *avoid* the case where ty' might end up as a
+primitive type: this is very uncool (totally wrong).
+
+NOTICE: in the example above we threw away e1 and e2, but
+not the string "Foo". How did we know to do that?
+
+Answer: for now anyway, we only handle the case of a function
+whose type is of form
+
+ bottomingFn :: forall a. t1 -> ... -> tn -> a
+ ^---------------------^ NB!
+
+Furthermore, we only count a bottomingApp if the function is
+applied to more than n args. If so, we transform:
+
+ bottomingFn ty e1 ... en en+1 ... em
+to
+ bottomingFn ty' e1 ... en
+
+That is, we discard en+1 .. em
+
+\begin{code}
+maybeErrorApp :: GenCoreExpr bndr Id -- Expr to look at
+ -> Maybe Type -- Just ty => a result type *already cloned*;
+ -- Nothing => don't know result ty; we
+ -- *pretend* that the result ty won't be
+ -- primitive -- somebody later must
+ -- ensure this.
+ -> Maybe (GenCoreExpr bndr Id)
+
+maybeErrorApp expr result_ty_maybe
+ = case collectArgs expr of
+ (Var fun, (TypeArg ty : other_args))
+ | isBottomingId fun
+ && maybeToBool result_ty_maybe -- we *know* the result type
+ -- (otherwise: live a fairy-tale existence...)
+ && not (isPrimType result_ty) ->
+ case splitSigmaTy (idType fun) of
+ ([tyvar_tmpl], [], tau_ty) ->
+ case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
+ let
+ n_args_to_keep = length arg_tys
+ args_to_keep = take n_args_to_keep other_args
+ in
+ if res_ty == mkTyVarTemplateTy tyvar_tmpl &&
+ n_args_to_keep <= length other_args
+ then
+ -- Phew! We're in business
+ Just (mkGenApp (Var fun)
+ (TypeArg result_ty : args_to_keep))
+ else
+ Nothing
+ }
+
+ other -> -- Function type wrong shape
+ Nothing
+ other -> Nothing
+ where
+ Just result_ty = result_ty_maybe
+\end{code}
+
+\begin{code}
+squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b -> Bool
+
+squashableDictishCcExpr cc expr
+ = if not (isDictCC cc) then
+ False -- that was easy...
+ else
+ squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
+ where
+ squashable (Var _) = True
+ squashable (CoTyApp f _) = squashable f
+ squashable (Con _ _ _) = True -- I think so... WDP 94/09
+ squashable (Prim _ _ _) = True -- ditto
+ squashable other = False
+-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Core-renaming utils}
+%* *
+%************************************************************************
+
+\begin{code}
+substCoreExpr :: ValEnv
+ -> TypeEnv -- TyVar=>Type
+ -> CoreExpr
+ -> UniqSM CoreExpr
+
+substCoreExpr venv tenv expr
+ -- if the envs are empty, then avoid doing anything
+ = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
+ returnUs expr
+ else
+ do_CoreExpr venv tenv expr
+\end{code}
+
+The equiv code for @Types@ is in @TyUtils@.
+
+Because binders aren't necessarily unique: we don't do @plusEnvs@
+(which check for duplicates); rather, we use the shadowing version,
+@growIdEnv@ (and shorthand @addOneToIdEnv@).
+
+@do_CoreBindings@ takes into account the semantics of a list of
+@CoreBindings@---things defined early in the list are visible later in
+the list, but not vice versa.
+
+\begin{code}
+type ValEnv = IdEnv CoreExpr
+
+do_CoreBindings :: ValEnv
+ -> TypeEnv
+ -> [CoreBinding]
+ -> UniqSM [CoreBinding]
+
+do_CoreBinding :: ValEnv
+ -> TypeEnv
+ -> CoreBinding
+ -> UniqSM (CoreBinding, ValEnv)
+
+do_CoreBindings venv tenv [] = returnUs []
+do_CoreBindings venv tenv (b:bs)
+ = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
+ do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
+ returnUs (new_b : new_bs)
+
+do_CoreBinding venv tenv (NonRec binder rhs)
+ = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
+
+ dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
+ -- now plug new bindings into envs
+ let new_venv = addOneToIdEnv venv old new in
+
+ returnUs (NonRec new_binder new_rhs, new_venv)
+
+do_CoreBinding venv tenv (Rec binds)
+ = -- for letrec, we plug in new bindings BEFORE cloning rhss
+ mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
+ let new_venv = growIdEnvList venv new_maps in
+
+ mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
+ returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
+ where
+ (binders, rhss) = unzip binds
+\end{code}
+
+\begin{code}
+do_CoreArg :: ValEnv
+ -> TypeEnv
+ -> CoreArg
+ -> UniqSM CoreExpr
+
+do_CoreArg venv tenv (LitArg lit) = returnUs (Lit lit)
+do_CoreArg venv tenv (TyArg ty) = panic "do_CoreArg: TyArg"
+do_CoreArg venv tenv (UsageArg usage) = panic "do_CoreArg: UsageArg"
+do_CoreArg venv tenv (VarArg v)
+ = returnUs (
+ case (lookupIdEnv venv v) of
+ Nothing -> --false:ASSERT(toplevelishId v)
+ Var v
+ Just expr -> expr
+ )
+\end{code}
+
+\begin{code}
+do_CoreExpr :: ValEnv
+ -> TypeEnv
+ -> CoreExpr
+ -> UniqSM CoreExpr
+
+do_CoreExpr venv tenv orig_expr@(Var var)
+ = returnUs (
+ case (lookupIdEnv venv var) of
+ Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
+ orig_expr
+ Just expr -> expr
+ )
+
+do_CoreExpr venv tenv e@(Lit _) = returnUs e
+
+do_CoreExpr venv tenv (Con con as)
+ = panic "CoreUtils.do_CoreExpr:Con"
+{- LATER:
+ = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
+ mkCoCon con new_as
+-}
+
+do_CoreExpr venv tenv (Prim op as)
+ = panic "CoreUtils.do_CoreExpr:Prim"
+{- LATER:
+ = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
+ do_PrimOp op `thenUs` \ new_op ->
+ mkCoPrim new_op new_as
+ where
+ do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
+ = let
+ new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
+ new_result_ty = applyTypeEnvToTy tenv result_ty
+ in
+ returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
+
+ do_PrimOp other_op = returnUs other_op
+-}
+
+do_CoreExpr venv tenv (Lam 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)
+
+do_CoreExpr venv tenv (App expr arg)
+ = panic "CoreUtils.do_CoreExpr:App"
+{-
+ = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
+ do_CoreArg venv tenv arg `thenUs` \ new_arg ->
+ mkCoApp new_expr new_arg
+-}
+
+do_CoreExpr venv tenv (Case expr alts)
+ = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
+ do_alts venv tenv alts `thenUs` \ new_alts ->
+ returnUs (Case new_expr new_alts)
+ where
+ do_alts venv tenv (AlgAlts alts deflt)
+ = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
+ do_default venv tenv deflt `thenUs` \ new_deflt ->
+ returnUs (AlgAlts new_alts new_deflt)
+ where
+ do_boxed_alt venv tenv (con, binders, expr)
+ = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
+ let new_venv = growIdEnvList venv new_vmaps in
+ do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
+ returnUs (con, new_binders, new_expr)
+
+
+ do_alts venv tenv (PrimAlts alts deflt)
+ = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
+ do_default venv tenv deflt `thenUs` \ new_deflt ->
+ returnUs (PrimAlts new_alts new_deflt)
+ where
+ do_unboxed_alt venv tenv (lit, expr)
+ = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
+ returnUs (lit, new_expr)
+
+ do_default venv tenv NoDefault = returnUs NoDefault
+
+ do_default venv tenv (BindDefault 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 (BindDefault new_binder new_expr)
+
+do_CoreExpr venv tenv (Let core_bind expr)
+ = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
+ -- and do the body of the let
+ do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
+ returnUs (Let new_bind new_expr)
+
+do_CoreExpr venv tenv (SCC label expr)
+ = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
+ returnUs (SCC label new_expr)
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FreeVars where
-import AnnCoreSyn(AnnCoreBinding, AnnCoreCaseAlternatives, AnnCoreCaseDefault, AnnCoreExpr', AnnCoreExpr(..))
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import UniqSet(IdSet(..), TyVarSet(..), UniqSet(..))
-data AnnCoreBinding a b c
-data AnnCoreCaseAlternatives a b c
-data AnnCoreCaseDefault a b c
-type AnnCoreExpr a b c = (c, AnnCoreExpr' a b c)
-data AnnCoreExpr' a b c
-data CoreExpr a b
-type CoreExprWithFVs = (FVInfo, AnnCoreExpr' Id Id FVInfo)
-type FVCoreBinding = CoreBinding (Id, UniqFM Id) Id
-type FVCoreExpr = CoreExpr (Id, UniqFM Id) Id
-data FVInfo = FVInfo (UniqFM Id) (UniqFM TyVar) LeakInfo
-data Id
-data UniType
-type IdSet = UniqFM Id
-data LeakInfo = MightLeak | LeakFree Int
-type TyVarSet = UniqFM TyVar
-type UniqSet a = UniqFM a
-addTopBindsFVs :: (UniqFM Id -> Id -> Bool) -> [CoreBinding Id Id] -> ([CoreBinding (Id, UniqFM Id) Id], UniqFM Id)
-freeTyVarsOf :: (FVInfo, AnnCoreExpr' Id Id FVInfo) -> UniqFM TyVar
-freeVars :: CoreExpr Id Id -> (FVInfo, AnnCoreExpr' Id Id FVInfo)
-freeVarsOf :: (FVInfo, AnnCoreExpr' Id Id FVInfo) -> UniqFM Id
-
module FreeVars (
freeVars,
-#ifdef DPH
--- ToDo: DPH: you should probably use addExprFVs now... [WDP]
- freeStuff, -- Need a function that gives fvs of
- -- an expression. I therefore need a
- -- way of passing in candidates or top
- -- level will always be empty.
-#endif {- Data Parallel Haskell -}
-
-- cheap and cheerful variant...
addTopBindsFVs,
FVCoreExpr(..), FVCoreBinding(..),
CoreExprWithFVs(..), -- For the above functions
- AnnCoreExpr(..), -- Dito
- FVInfo(..), LeakInfo(..),
+ AnnCoreExpr(..), -- Dito
+ FVInfo(..), LeakInfo(..)
-- and to make the interface self-sufficient...
- CoreExpr, Id, IdSet(..), TyVarSet(..), UniqSet(..), UniType,
- AnnCoreExpr', AnnCoreBinding, AnnCoreCaseAlternatives,
- AnnCoreCaseDefault
) where
-import PlainCore -- input
import AnnCoreSyn -- output
-import AbsPrel ( PrimOp(..), PrimKind -- for CCallOp
+import PrelInfo ( PrimOp(..), PrimRep -- for CCallOp
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( extractTyVarsFromTy )
-import BasicLit ( typeOfBasicLit )
-import Id ( getIdUniType, getIdArity, toplevelishId, isBottomingId )
+import Type ( extractTyVarsFromTy )
+import Id ( idType, getIdArity, toplevelishId, isBottomingId )
import IdInfo -- Wanted for arityMaybe, but it seems you have
-- to import it all... (Death to the Instance Virus!)
import Maybes
noTyVarCands = emptyUniqSet
noIdCands = emptyUniqSet
-data FVInfo = FVInfo
+data FVInfo = FVInfo
IdSet -- Free ids
TyVarSet -- Free tyvars
LeakInfo
aFreeTyVar t = singletonUniqSet t
is_among = elementOfUniqSet
combine = unionUniqSets
-munge_id_ty i = mkUniqSet (extractTyVarsFromTy (getIdUniType i))
+munge_id_ty i = mkUniqSet (extractTyVarsFromTy (idType i))
combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2)
- = FVInfo (fvs1 `combine` fvs2)
- (tfvs1 `combine` tfvs2)
+ = FVInfo (fvs1 `combine` fvs2)
+ (tfvs1 `combine` tfvs2)
(leak1 `orLeak` leak2)
\end{code}
Main public interface:
\begin{code}
-freeVars :: PlainCoreExpr -> CoreExprWithFVs
+freeVars :: CoreExpr -> CoreExprWithFVs
freeVars expr = fvExpr noIdCands noTyVarCands expr
\end{code}
fvExpr :: IdCands -- In-scope Ids
-> TyVarCands -- In-scope tyvars
- -> PlainCoreExpr
+ -> CoreExpr
-> CoreExprWithFVs
-fvExpr id_cands tyvar_cands (CoVar v)
+fvExpr id_cands tyvar_cands (Var v)
= (FVInfo (if (v `is_among` id_cands)
then aFreeId v
else noFreeIds)
Nothing -> lEAK_FREE_0
Just arity -> LeakFree arity
-fvExpr id_cands tyvar_cands (CoLit k)
+fvExpr id_cands tyvar_cands (Lit k)
= (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnCoLit k)
-fvExpr id_cands tyvar_cands (CoCon c tys args)
+fvExpr id_cands tyvar_cands (Con c tys args)
= (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoCon c tys args)
where
args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
-fvExpr id_cands tyvar_cands (CoPrim op@(CCallOp _ _ _ _ res_ty) tys args)
+fvExpr id_cands tyvar_cands (Prim op@(CCallOp _ _ _ _ res_ty) tys args)
= ASSERT (null tys)
(FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
where
args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars (res_ty:tys)
-fvExpr id_cands tyvar_cands (CoPrim op tys args)
+fvExpr id_cands tyvar_cands (Prim op tys args)
= (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args)
where
args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args
tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys
-fvExpr id_cands tyvar_cands (CoLam binders body)
- = (FVInfo (freeVarsOf body2 `minusUniqSet` mkUniqSet binders)
- (freeTyVarsOf body2 `combine` binder_ftvs)
+fvExpr id_cands tyvar_cands (Lam binder body)
+ = (FVInfo (freeVarsOf body2 `minusUniqSet` singletonUniqSet binder)
+ (freeTyVarsOf body2 `combine` munge_id_ty binder)
leakiness,
- AnnCoLam binders body2)
+ AnnCoLam binder body2)
where
-- We need to collect free tyvars from the binders
- body2 = fvExpr (mkUniqSet binders `combine` id_cands) tyvar_cands body
-
- binder_ftvs
- = foldr (combine . munge_id_ty) noFreeTyVars binders
+ body2 = fvExpr (singletonUniqSet binder `combine` id_cands) tyvar_cands body
- no_args = length binders
leakiness = case leakinessOf body2 of
- MightLeak -> LeakFree no_args
- LeakFree n -> LeakFree (n + no_args)
+ MightLeak -> LeakFree 1
+ LeakFree n -> LeakFree (n + 1)
fvExpr id_cands tyvar_cands (CoTyLam tyvar body)
= (FVInfo (freeVarsOf body2)
where
body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body
-fvExpr id_cands tyvar_cands (CoApp fun arg)
+fvExpr id_cands tyvar_cands (App fun arg)
= (FVInfo (freeVarsOf fun2 `combine` fvs_arg)
(freeTyVarsOf fun2)
leakiness,
expr2 = fvExpr id_cands tyvar_cands expr
tfvs_arg = freeTy tyvar_cands ty
-fvExpr id_cands tyvar_cands (CoCase expr alts)
+fvExpr id_cands tyvar_cands (Case expr alts)
= (combineFVInfo expr_fvinfo alts_fvinfo,
AnnCoCase expr2 alts')
where
expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr
(alts_fvinfo, alts') = annotate_alts alts
- annotate_alts (CoAlgAlts alts deflt)
+ annotate_alts (AlgAlts alts deflt)
= (fvinfo, AnnCoAlgAlts alts' deflt')
where
(alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts)
(deflt_fvinfo, deflt') = annotate_default deflt
- fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
+ fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s
ann_boxed_alt (con, params, rhs)
= (FVInfo (freeVarsOf rhs' `minusUniqSet` mkUniqSet params)
param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params
-- We need to collect free tyvars from the binders
- annotate_alts (CoPrimAlts alts deflt)
+ annotate_alts (PrimAlts alts deflt)
= (fvinfo, AnnCoPrimAlts alts' deflt')
where
(alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts)
where
rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs
-#ifdef DPH
- annotate_alts id_cands tyvar_cands (CoParAlgAlts tycon ctxt binders alts deflt)
- = ((alts_fvs `minusUniqSet` (mkUniqSet binders)) `combine` deflt_fvs,
- AnnCoParAlgAlts tycon ctxt binders alts' deflt')
- where
- (alts_fvs_sets, alts') = unzip (map (ann_boxed_par_alt id_cands tyvar_cands) alts)
- alts_fvs = unionManyUniqSets alts_fvs_sets
- (deflt_fvs, ???ToDo:DPH, deflt') = annotate_default deflt
-
- ann_boxed_par_alt id_cands tyvar_cands (con, rhs)
- = (rhs_fvs, (con, rhs'))
- where
- rhs' = fvExpr (mkUniqSet binders `combine` id_cands) tyvar_cands rhs
- rhs_fvs = freeVarsOf rhs'
-
- annotate_alts id_cands tyvar_cands (CoParPrimAlts tycon ctxt alts deflt)
- = (alts_fvs `combine` deflt_fvs,
- AnnCoParPrimAlts tycon ctxt alts' deflt')
- where
- (alts_fvs_sets, alts') = unzip (map (ann_unboxed_par_alt id_cands tyvar_cands) alts)
- alts_fvs = unionManyUniqSets alts_fvs_sets
- (deflt_fvs, ??? ToDo:DPH, deflt') = annotate_default deflt
-
- ann_unboxed_par_alt id_cands tyvar_cands (lit, rhs)
- = (rhs_fvs, (lit, rhs'))
- where
- rhs' = fvExpr id_cands tyvar_cands rhs
- rhs_fvs = freeVarsOf rhs'
-#endif {- Data Parallel Haskell -}
-
- annotate_default CoNoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
+ annotate_default NoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG,
AnnCoNoDefault)
- annotate_default (CoBindDefault binder rhs)
+ annotate_default (BindDefault binder rhs)
= (FVInfo (freeVarsOf rhs' `minusUniqSet` aFreeId binder)
(freeTyVarsOf rhs' `combine` binder_ftvs)
(leakinessOf rhs'),
binder_ftvs = munge_id_ty binder
-- We need to collect free tyvars from the binder
-fvExpr id_cands tyvar_cands (CoLet (CoNonRec binder rhs) body)
+fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body)
= (FVInfo (freeVarsOf rhs' `combine` body_fvs)
(freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs)
(leakinessOf rhs' `orLeak` leakinessOf body2),
binder_ftvs = munge_id_ty binder
-- We need to collect free tyvars from the binder
-fvExpr id_cands tyvar_cands (CoLet (CoRec binds) body)
+fvExpr id_cands tyvar_cands (Let (Rec binds) body)
= (FVInfo (binds_fvs `combine` body_fvs)
(rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs)
(leakiness_of_rhss `orLeak` leakinessOf body2),
binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
-- We need to collect free tyvars from the binders
-fvExpr id_cands tyvar_cands (CoSCC label expr)
+fvExpr id_cands tyvar_cands (SCC label expr)
= (fvinfo, AnnCoSCC label expr2)
where
expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
-
-#ifdef DPH
-fvExpr id_cands tyvar_cands e@(CoParCon c ctxt tys args)
- = ((args_fvs, typeOfCoreExpr e), AnnCoParCon c ctxt tys args')
- where
- args' = map (fvExpr id_cands tyvar_cands) args
- args_fvs = unionManyUniqSets [ fvs | ((fvs,_), _) <- args' ]
-
-fvExpr id_cands tyvar_cands e@(CoParComm ctxt expr comm)
- = ((expr_fvs `combine` comm_fvs, tyOf expr2), AnnCoParComm ctxt expr2 comm')
- where
- expr2 = fvExpr id_cands tyvar_cands expr
- expr_fvs = freeVarsOf expr2
- (comm_fvs,comm') = free_stuff_comm id_cands tyvar_cands comm
-
- free_stuff_comm id_cands tyvar_cands (CoParSend exprs)
- = let exprs' = map (fvExpr id_cands tyvar_cands) exprs in
- let exprs_fvs = unionManyUniqSets [fvs | ((fvs,_), _) <- exprs' ] in
- (exprs_fvs,AnnCoParSend exprs')
-
- free_stuff_comm id_cands tyvar_cands (CoParFetch exprs)
- = let exprs' = map (fvExpr id_cands tyvar_cands) exprs in
- let exprs_fvs = unionManyUniqSets [fvs | ((fvs,_), _) <- exprs' ] in
- (exprs_fvs,AnnCoParFetch exprs')
-
- free_stuff_comm id_cands tyvar_cands (CoToPodized)
- = (emptyUniqSet, AnnCoToPodized)
-
- free_stuff_comm id_cands tyvar_cands (CoFromPodized)
- = (emptyUniqSet, AnnCoFromPodized)
-#endif {- Data Parallel Haskell -}
\end{code}
\begin{code}
-freeAtom :: IdCands -> PlainCoreAtom -> IdSet
+freeAtom :: IdCands -> CoreArg -> IdSet
-freeAtom cands (CoLitAtom k) = noFreeIds
-freeAtom cands (CoVarAtom v) | v `is_among` cands = aFreeId v
+freeAtom cands (LitArg k) = noFreeIds
+freeAtom cands (VarArg v) | v `is_among` cands = aFreeId v
| otherwise = noFreeIds
-freeTy :: TyVarCands -> UniType -> TyVarSet
+freeTy :: TyVarCands -> Type -> TyVarSet
freeTy cands ty = mkUniqSet (extractTyVarsFromTy ty) `intersectUniqSets` cands
The free vars attached to a let(rec) binder are the free vars of the
rhs of the binding. In the case of letrecs, this set excludes the
binders themselves.
-\item
+\item
The free vars attached to a case alternative binder are the free
vars of the alternative, excluding the alternative's binders.
\end{itemize}
There's a predicate carried in which tells what is a free-var
candidate. It is passed the Id and a set of in-scope Ids.
-(Global) constructors used on the rhs in a CoCon are also treated as
+(Global) constructors used on the rhs in a Con are also treated as
potential free-var candidates (though they will not be recorded in the
in-scope set). The predicate must decide if they are to be recorded as
free-vars.
\begin{code}
type FVCoreBinder = (Id, IdSet)
-type FVCoreExpr = CoreExpr FVCoreBinder Id
-type FVCoreBinding = CoreBinding FVCoreBinder Id
+type FVCoreExpr = GenCoreExpr FVCoreBinder Id
+type FVCoreBinding = GenCoreBinding FVCoreBinder Id
type InterestingIdFun
= IdSet -- Non-top-level in-scope variables
\begin{code}
addExprFVs :: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
- -> PlainCoreExpr
+ -> CoreExpr
-> (FVCoreExpr, IdSet)
-addExprFVs fv_cand in_scope (CoVar v)
- = (CoVar v, if fv_cand in_scope v
+addExprFVs fv_cand in_scope (Var v)
+ = (Var v, if fv_cand in_scope v
then aFreeId v
else noFreeIds)
-addExprFVs fv_cand in_scope (CoLit lit) = (CoLit lit, noFreeIds)
+addExprFVs fv_cand in_scope (Lit lit) = (Lit lit, noFreeIds)
-addExprFVs fv_cand in_scope (CoCon con tys args)
- = (CoCon con tys args,
- if fv_cand in_scope con
+addExprFVs fv_cand in_scope (Con con tys args)
+ = (Con con tys args,
+ if fv_cand in_scope con
then aFreeId con
else noFreeIds
`combine`
unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
-addExprFVs fv_cand in_scope (CoPrim op tys args)
- = (CoPrim op tys args,
+addExprFVs fv_cand in_scope (Prim op tys args)
+ = (Prim op tys args,
unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args))
-addExprFVs fv_cand in_scope (CoLam binders body)
- = (CoLam (binders `zip` (repeat lam_fvs)) new_body, lam_fvs)
+addExprFVs fv_cand in_scope (Lam binder body)
+ = (Lam (binder,lam_fvs) new_body, lam_fvs)
where
- binder_set = mkUniqSet binders
+ binder_set = singletonUniqSet binder
new_in_scope = in_scope `combine` binder_set
(new_body, body_fvs) = addExprFVs fv_cand new_in_scope body
lam_fvs = body_fvs `minusUniqSet` binder_set
where
(body2, body_fvs) = addExprFVs fv_cand in_scope body
-addExprFVs fv_cand in_scope (CoApp fun arg)
- = (CoApp fun2 arg, fun_fvs `combine` fvsOfAtom fv_cand in_scope arg)
+addExprFVs fv_cand in_scope (App fun arg)
+ = (App fun2 arg, fun_fvs `combine` fvsOfAtom fv_cand in_scope arg)
where
(fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
where
(fun2, fun_fvs) = addExprFVs fv_cand in_scope fun
-addExprFVs fv_cand in_scope (CoCase scrut alts)
- = (CoCase scrut' alts', scrut_fvs `combine` alts_fvs)
+addExprFVs fv_cand in_scope (Case scrut alts)
+ = (Case scrut' alts', scrut_fvs `combine` alts_fvs)
where
(scrut', scrut_fvs) = addExprFVs fv_cand in_scope scrut
(alts', alts_fvs)
= case alts of
- CoAlgAlts alg_alts deflt -> (CoAlgAlts alg_alts' deflt', fvs)
+ AlgAlts alg_alts deflt -> (AlgAlts alg_alts' deflt', fvs)
where
(alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts)
(deflt', deflt_fvs) = do_deflt deflt
fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
- CoPrimAlts prim_alts deflt -> (CoPrimAlts prim_alts' deflt', fvs)
+ PrimAlts prim_alts deflt -> (PrimAlts prim_alts' deflt', fvs)
where
(prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts)
(deflt', deflt_fvs) = do_deflt deflt
fvs = unionManyUniqSets (deflt_fvs : alt_fvs)
- do_alg_alt :: (Id, [Id], PlainCoreExpr)
+ do_alg_alt :: (Id, [Id], CoreExpr)
-> ((Id, [FVCoreBinder], FVCoreExpr), IdSet)
do_alg_alt (con, args, rhs) = ((con, args `zip` (repeat fvs), rhs'), fvs)
new_in_scope = in_scope `combine` arg_set
(rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
fvs = rhs_fvs `minusUniqSet` arg_set
- arg_set = mkUniqSet args
+ arg_set = mkUniqSet args
do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs)
where
(rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs
- do_deflt CoNoDefault = (CoNoDefault, noFreeIds)
- do_deflt (CoBindDefault var rhs)
- = (CoBindDefault (var,fvs) rhs', fvs)
+ do_deflt NoDefault = (NoDefault, noFreeIds)
+ do_deflt (BindDefault var rhs)
+ = (BindDefault (var,fvs) rhs', fvs)
where
new_in_scope = in_scope `combine` var_set
(rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs
fvs = rhs_fvs `minusUniqSet` var_set
- var_set = aFreeId var
+ var_set = aFreeId var
-addExprFVs fv_cand in_scope (CoLet binds body)
- = (CoLet binds' body2, fvs_binds `combine` (fvs_body `minusUniqSet` binder_set))
+addExprFVs fv_cand in_scope (Let binds body)
+ = (Let binds' body2, fvs_binds `combine` (fvs_body `minusUniqSet` binder_set))
where
(binds', fvs_binds, new_in_scope, binder_set)
= addBindingFVs fv_cand in_scope binds
(body2, fvs_body) = addExprFVs fv_cand new_in_scope body
-addExprFVs fv_cand in_scope (CoSCC label expr)
- = (CoSCC label expr2, expr_fvs)
+addExprFVs fv_cand in_scope (SCC label expr)
+ = (SCC label expr2, expr_fvs)
where
(expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
-
--- ToDo: DPH: add stuff here
\end{code}
\begin{code}
addBindingFVs
:: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
- -> PlainCoreBinding
+ -> CoreBinding
-> (FVCoreBinding,
IdSet, -- Free vars of binding group
IdSet, -- Augmented in-scope Ids
IdSet) -- Set of Ids bound by this binding
-addBindingFVs fv_cand in_scope (CoNonRec binder rhs)
- = (CoNonRec binder' rhs', fvs, new_in_scope, binder_set)
- where
+addBindingFVs fv_cand in_scope (NonRec binder rhs)
+ = (NonRec binder' rhs', fvs, new_in_scope, binder_set)
+ where
((binder', rhs'), fvs) = do_pair fv_cand in_scope binder_set (binder, rhs)
new_in_scope = in_scope `combine` binder_set
binder_set = aFreeId binder
-addBindingFVs fv_cand in_scope (CoRec pairs)
- = (CoRec pairs', unionManyUniqSets fvs_s, new_in_scope, binder_set)
+addBindingFVs fv_cand in_scope (Rec pairs)
+ = (Rec pairs', unionManyUniqSets fvs_s, new_in_scope, binder_set)
where
binders = [binder | (binder,_) <- pairs]
binder_set = mkUniqSet binders
\begin{code}
addTopBindsFVs
:: InterestingIdFun -- "Interesting id" predicate
- -> [PlainCoreBinding]
+ -> [CoreBinding]
-> ([FVCoreBinding],
IdSet)
\begin{code}
fvsOfAtom :: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
- -> PlainCoreAtom
+ -> CoreArg
-> IdSet
-fvsOfAtom fv_cand in_scope (CoVarAtom v)
+fvsOfAtom fv_cand in_scope (VarArg v)
= if fv_cand in_scope v
then aFreeId v
else noFreeIds
do_pair :: InterestingIdFun -- "Interesting id" predicate
-> IdSet -- In scope ids
-> IdSet
- -> (Id, PlainCoreExpr)
+ -> (Id, CoreExpr)
-> ((FVCoreBinder, FVCoreExpr), IdSet)
do_pair fv_cand in_scope binder_set (binder,rhs)
+++ /dev/null
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-HaskellSuffixRules()
-
-/* LIT2LATEX_OPTS=-tbird */
-
-LIT2LATEX_OPTS=-ttgrind
-
-LitDocRootTargetWithNamedOutput(root,lit,root-standalone)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PlainCore where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import CoreFuns(atomToExpr, bindersOf, coreExprArity, digForLambdas, escErrorMsg, exprSmallEnoughToDup, instCoreBindings, instCoreExpr, isWrapperFor, manifestlyBottom, manifestlyWHNF, maybeErrorApp, mkCoApps, mkCoLam, mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase, mkCoLetrecAny, mkCoLetrecNoUnboxed, mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase, mkCoTyApps, mkCoTyLam, mkCoreIfThenElse, mkErrorCoApp, mkFunction, nonErrorRHSs, pairsFromCoreBinds, squashableDictishCcExpr, substCoreExpr, substCoreExprUS, typeOfCoreAlts, typeOfCoreExpr)
-import CoreSyn(CoreArg(..), CoreAtom(..), CoreBinding(..), CoreCaseAlternatives(..), CoreCaseDefault(..), CoreExpr(..), applyToArgs, collectArgs, decomposeArgs, mkCoTyApp, pprCoreExpr)
-import CoreUnfold(calcUnfoldingGuidance, mentionedInUnfolding, pprCoreUnfolding)
-import CostCentre(CostCentre)
-import FreeVars(FVCoreBinding(..), FVCoreExpr(..), addTopBindsFVs)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(Demand, IdInfo)
-import Maybes(Labda)
-import NameTypes(FullName)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimOps(PrimOp)
-import SimplEnv(UnfoldingGuidance)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import TyVarEnv(TyVarEnv(..), TypeEnv(..))
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import UniqFM(UniqFM)
-import UniqSet(IdSet(..), UniqSet(..))
-import Unique(UniqSM(..), Unique, UniqueSupply)
-class NamedThing a where
- getExportFlag :: a -> ExportFlag
- isLocallyDefined :: a -> Bool
- getOrigName :: a -> (_PackedString, _PackedString)
- getOccurrenceName :: a -> _PackedString
- getInformingModules :: a -> [_PackedString]
- getSrcLoc :: a -> SrcLoc
- getTheUnique :: a -> Unique
- hasType :: a -> Bool
- getType :: a -> UniType
- fromPreludeCore :: a -> Bool
-class Outputable a where
- ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data Bag a
-data BasicLit
-data BinderInfo
-data Class
-data CoreArg a = TypeArg UniType | ValArg (CoreAtom a)
-data CoreAtom a = CoVarAtom a | CoLitAtom BasicLit
-data CoreBinding a b = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)]
-data CoreCaseAlternatives a b = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b)
-data CoreCaseDefault a b = CoNoDefault | CoBindDefault a (CoreExpr a b)
-data CoreExpr a b = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b)
-data CostCentre
-type FVCoreBinding = CoreBinding (Id, UniqFM Id) Id
-type FVCoreExpr = CoreExpr (Id, UniqFM Id) Id
-data Id
-type IdEnv a = UniqFM a
-data Demand
-data IdInfo
-data Labda a
-data FullName
-data ExportFlag
-type PlainCoreArg = CoreArg Id
-type PlainCoreAtom = CoreAtom Id
-type PlainCoreBinding = CoreBinding Id Id
-type PlainCoreCaseAlternatives = CoreCaseAlternatives Id Id
-type PlainCoreCaseDefault = CoreCaseDefault Id Id
-type PlainCoreExpr = CoreExpr Id Id
-type PlainCoreProgram = [CoreBinding Id Id]
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data PrimOp
-data UnfoldingGuidance
-data SrcLoc
-data TyCon
-data TyVar
-type TyVarEnv a = UniqFM a
-type TypeEnv = UniqFM UniType
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType
-data UniqFM a
-type IdSet = UniqFM Id
-type UniqSet a = UniqFM a
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique
-data UniqueSupply
-atomToExpr :: CoreAtom b -> CoreExpr a b
-bindersOf :: CoreBinding b a -> [b]
-coreExprArity :: (Id -> Labda (CoreExpr a Id)) -> CoreExpr a Id -> Int
-digForLambdas :: CoreExpr a b -> ([TyVar], [a], CoreExpr a b)
-escErrorMsg :: [Char] -> [Char]
-exprSmallEnoughToDup :: CoreExpr a Id -> Bool
-instCoreBindings :: UniqueSupply -> [CoreBinding Id Id] -> (UniqueSupply, [CoreBinding Id Id])
-instCoreExpr :: UniqueSupply -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
-isWrapperFor :: CoreExpr Id Id -> Id -> Bool
-manifestlyBottom :: CoreExpr a Id -> Bool
-manifestlyWHNF :: CoreExpr a Id -> Bool
-maybeErrorApp :: CoreExpr a Id -> Labda UniType -> Labda (CoreExpr a Id)
-mkCoApps :: CoreExpr Id Id -> [CoreExpr Id Id] -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
-mkCoLam :: [a] -> CoreExpr a b -> CoreExpr a b
-mkCoLetAny :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetNoUnboxed :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetUnboxedToCase :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetrecAny :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetrecNoUnboxed :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsAny :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsNoUnboxed :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoLetsUnboxedToCase :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoTyApps :: CoreExpr a b -> [UniType] -> CoreExpr a b
-mkCoTyLam :: [TyVar] -> CoreExpr a b -> CoreExpr a b
-mkCoreIfThenElse :: CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id
-mkErrorCoApp :: UniType -> Id -> [Char] -> CoreExpr Id Id
-mkFunction :: [TyVar] -> [a] -> CoreExpr a b -> CoreExpr a b
-nonErrorRHSs :: CoreCaseAlternatives a Id -> [CoreExpr a Id]
-pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
-squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
-substCoreExpr :: UniqueSupply -> UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
-substCoreExprUS :: UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
-typeOfCoreAlts :: CoreCaseAlternatives Id Id -> UniType
-typeOfCoreExpr :: CoreExpr Id Id -> UniType
-applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b
-collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b])
-decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a])
-mkCoTyApp :: CoreExpr a b -> UniType -> CoreExpr a b
-pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep
-calcUnfoldingGuidance :: Bool -> Int -> CoreExpr Id Id -> UnfoldingGuidance
-mentionedInUnfolding :: (a -> Id) -> CoreExpr a Id -> ([Id], [TyCon], [Class], Bool)
-pprCoreUnfolding :: CoreExpr Id Id -> Int -> Bool -> PrettyRep
-addTopBindsFVs :: (UniqFM Id -> Id -> Bool) -> [CoreBinding Id Id] -> ([CoreBinding (Id, UniqFM Id) Id], UniqFM Id)
-pprBigCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep
-pprPlainCoreBinding :: PprStyle -> CoreBinding Id Id -> Int -> Bool -> PrettyRep
-pprTypedCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep
-instance Eq Class
-instance Eq Id
-instance Eq Demand
-instance Eq UniType
-instance Eq Unique
-instance Ord Class
-instance Ord Id
-instance Ord Demand
-instance Ord Unique
-instance NamedThing Class
-instance NamedThing Id
-instance NamedThing FullName
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable Bool
-instance Outputable Class
-instance Outputable a => Outputable (CoreArg a)
-instance Outputable a => Outputable (CoreAtom a)
-instance (Outputable a, Outputable b) => Outputable (CoreBinding a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b)
-instance (Outputable a, Outputable b) => Outputable (CoreExpr a b)
-instance Outputable Id
-instance Outputable Demand
-instance Outputable FullName
-instance Outputable UniType
-instance Outputable a => Outputable [a]
-instance Text Demand
-instance Text Unique
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[PlainCore]{``Plain'' core syntax: the usual parameterisation}
-
-This module defines a particular parameterisation of the @CoreSyntax@
-data type. Both binders and bindees are just @Ids@. This is the
-normal thing.
-
-\begin{code}
-#include "HsVersions.h"
-
-module PlainCore (
- PlainCoreProgram(..), PlainCoreBinding(..), PlainCoreExpr(..),
- PlainCoreAtom(..), PlainCoreCaseAlternatives(..),
- PlainCoreCaseDefault(..), PlainCoreArg(..),
-#ifdef DPH
- PlainCoreParQuals(..),
- PlainCoreParCommunicate(..),
- CoreParCommunicate(..),
- CoreParQuals(..),
- isParCoreCaseAlternative,
- mkNonRecBinds,
-#endif
- pprPlainCoreBinding,
- pprBigCoreBinder, pprTypedCoreBinder, -- not exported: pprBabyCoreBinder,
-
- CoreBinding(..), CoreExpr(..), CoreAtom(..), -- re-exported
- CoreCaseAlternatives(..), CoreCaseDefault(..),
- pprCoreExpr,
-
- CoreArg(..), applyToArgs, decomposeArgs, collectArgs,
-
- -- and the related utility functions from CoreFuns...
-
- typeOfCoreExpr, typeOfCoreAlts,
- instCoreExpr, substCoreExpr, -- UNUSED: cloneCoreExpr,
- substCoreExprUS, -- UNUSED: instCoreExprUS, cloneCoreExprUS,
- instCoreBindings,
- mkCoLam, mkCoreIfThenElse,
--- mkCoApp, mkCoCon, mkCoPrim, -- no need for export
- mkCoApps,
- mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
- mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
- mkCoLetrecAny, mkCoLetrecNoUnboxed,
- mkCoTyLam, mkCoTyApp, mkCoTyApps,
- mkErrorCoApp, escErrorMsg,
- pairsFromCoreBinds,
- mkFunction, atomToExpr,
- digForLambdas,
- exprSmallEnoughToDup,
- manifestlyWHNF, manifestlyBottom, --UNUSED: manifestWHNFArgs,
- coreExprArity,
- isWrapperFor,
- maybeErrorApp,
---UNUSED: boilsDownToConApp,
- nonErrorRHSs, bindersOf,
- squashableDictishCcExpr,
-
- calcUnfoldingGuidance,
- pprCoreUnfolding,
- mentionedInUnfolding,
-
- -- and one variant of free-var-finding stuff:
- addTopBindsFVs, FVCoreExpr(..), FVCoreBinding(..),
-
- -- and to make the interface self-sufficient ...
- Outputable(..), NamedThing(..),
- ExportFlag, SrcLoc, Unique,
- Pretty(..), PprStyle, PrettyRep,
-
- BasicLit, BinderInfo, Class, Id, Demand, IdInfo, FullName,
- UnfoldingGuidance, UniType, TauType(..), ThetaType(..),
- SigmaType(..), TyVar, TyCon, CostCentre, PrimOp, UniqueSupply,
- UniqSM(..), IdEnv(..), UniqFM,
- TyVarEnv(..), TypeEnv(..), IdSet(..), UniqSet(..),
- Maybe, Bag
- IF_ATTACK_PRAGMAS(COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- IF_ATTACK_PRAGMAS(COMMA initUs) -- profiling
-
--- NOTE(hilly) Added UniqSM for cloneFunctions
-
- ) where
-
---IMPORT_Trace -- ToDo: rm (debugging)
-
-import CoreSyn -- mostly re-exporting this stuff
-import CoreFuns
-import CoreUnfold
-
-import AbsUniType ( TauType(..), ThetaType(..), SigmaType(..),
- Class, UniType, FullName
- IF_ATTACK_PRAGMAS(COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import FreeVars
-import Id ( getIdUniType, getIdStrictness, getIdInfo,
- Id, TypeEnv(..)
- )
-import IdEnv -- ( nullIdEnv, IdEnv )
-import IdInfo
-import Maybes ( Maybe(..) )
-import Outputable
-import Pretty
-import Unique ( UniqSM(..), Unique
- IF_ATTACK_PRAGMAS(COMMA initUs)
- )
-import Util
-
-infixr 9 `thenUf`, `thenUf_`
-\end{code}
-
-The ``Core things'' just described are parameterised with respect to
-the information kept about binding occurrences and bound occurrences
-of variables.
-
-The ``Plain Core things'' are instances of the ``Core things'' in
-which nothing but a name is kept, for both binders and variables.
-\begin{code}
-type PlainCoreProgram = [CoreBinding Id Id]
-type PlainCoreBinding = CoreBinding Id Id
-type PlainCoreExpr = CoreExpr Id Id
-type PlainCoreAtom = CoreAtom Id
-#ifdef DPH
-type PlainCoreParQuals = CoreParQuals Id Id
-type PlainCoreParCommunicate = CoreParCommunicate Id Id
-#endif {- Data Parallel Haskell -}
-type PlainCoreCaseAlternatives = CoreCaseAlternatives Id Id
-type PlainCoreCaseDefault = CoreCaseDefault Id Id
-
-type PlainCoreArg = CoreArg Id
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[printing-PlainCore]{Printing @PlainCore@ things}
-%* *
-%************************************************************************
-
-The most common core-printing interface:
-\begin{code}
-pprPlainCoreBinding :: PprStyle -> PlainCoreBinding -> Pretty
-
-pprPlainCoreBinding sty (CoNonRec binder expr)
- = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
- 4 (pprCoreExpr sty pprBigCoreBinder pprBabyCoreBinder ppr expr)
-
-pprPlainCoreBinding sty (CoRec binds)
- = ppAboves [ifPprDebug sty (ppStr "{- plain CoRec -}"),
- ppAboves (map ppr_bind binds),
- ifPprDebug sty (ppStr "{- end plain CoRec -}")]
- where
- ppr_bind (binder, expr)
- = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
- 4 (pprCoreExpr sty pprBigCoreBinder pprBabyCoreBinder ppr expr)
-\end{code}
-
-Other printing bits-and-bobs used with the general @pprCoreBinding@
-and @pprCoreExpr@ functions.
-\begin{code}
-pprBigCoreBinder sty binder
- = ppAboves [sig, pragmas, ppr sty binder]
- where
- sig = ifnotPprShowAll sty (
- ppHang (ppCat [ppr sty binder, ppStr "::"])
- 4 (ppr sty (getIdUniType binder)))
-
- pragmas = ifnotPprForUser sty (
- ppIdInfo sty binder True{-specs, please-} id nullIdEnv (getIdInfo binder))
-
-pprBabyCoreBinder sty binder
- = ppCat [ppr sty binder, pp_strictness]
- where
- pp_strictness
- = case (getIdStrictness binder) of
- NoStrictnessInfo -> ppNil
- BottomGuaranteed -> ppStr "{- _!_ -}"
- StrictnessInfo xx _ -> ppStr ("{- " ++ (showList xx "") ++ " -}")
-
-pprTypedCoreBinder sty binder
- = ppBesides [ppLparen, ppCat [ppr sty binder,
- ppStr "::", ppr sty (getIdUniType binder)],
- ppRparen]
-\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+%************************************************************************
+%* *
+\section[PprCore]{Printing of Core syntax, including for interfaces}
+%* *
+%************************************************************************
+
+\begin{code}
+#include "HsVersions.h"
+
+module PprCore (
+ pprCoreExpr,
+ pprCoreBinding,
+ pprBigCoreBinder,
+ pprTypedCoreBinder,
+ pprPlainCoreBinding
+
+ -- these are here to make the instances go in 0.26:
+#if __GLASGOW_HASKELL__ <= 26
+ , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
+ , GenCoreCaseDefault, GenCoreArg
+#endif
+ ) where
+
+import Ubiq{-uitous-}
+
+import CoreSyn
+import CostCentre ( showCostCentre )
+import Id ( idType, getIdInfo, getIdStrictness,
+ nullIdEnv, DataCon(..), GenId{-instances-}
+ )
+import IdInfo ( ppIdInfo, StrictnessInfo(..) )
+import Literal ( Literal{-instances-} )
+import Outputable -- quite a few things
+import PprType ( pprType_Internal,
+ GenType{-instances-}, GenTyVar{-instance-}
+ )
+import PprStyle ( PprStyle(..) )
+import Pretty
+import PrimOp ( PrimOp{-instances-} )
+import TyVar ( GenTyVar{-instances-} )
+import Unique ( Unique{-instances-} )
+import Usage ( GenUsage{-instances-} )
+import Util ( panic{-ToDo:rm-} )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Public interfaces for Core printing (excluding instances)}
+%* *
+%************************************************************************
+
+@pprCoreBinding@ and @pprCoreExpr@ let you give special printing
+function for ``major'' val_bdrs (those next to equal signs :-),
+``minor'' ones (lambda-bound, case-bound), and bindees. They would
+usually be called through some intermediary.
+
+The binder/occ printers take the default ``homogenized'' (see
+@PrintEnv@...) @Pretty@ and the binder/occ. They can either use the
+homogenized one, or they can ignore it completely. In other words,
+the things passed in act as ``hooks'', getting the last word on how to
+print something.
+
+@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
+
+\begin{code}
+pprPlainCoreBinding :: PprStyle -> CoreBinding -> Pretty
+
+pprCoreBinding
+ :: (Eq tyvar, Outputable tyvar,
+ Eq uvar, Outputable uvar,
+ Outputable bndr,
+ Outputable occ)
+ => PprStyle
+ -> (bndr -> Pretty) -- to print "major" val_bdrs
+ -> (bndr -> Pretty) -- to print "minor" val_bdrs
+ -> (occ -> Pretty) -- to print bindees
+ -> GenCoreBinding bndr occ tyvar uvar
+ -> Pretty
+
+pprCoreBinding sty pbdr1 pbdr2 pocc bind
+ = ppr_bind (initial_pe sty (Left (pbdr1, pbdr2, pocc))) bind
+
+pprPlainCoreBinding sty (NonRec binder expr)
+ = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
+ 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
+
+pprPlainCoreBinding sty (Rec binds)
+ = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
+ ppAboves (map ppr_bind binds),
+ ifPprDebug sty (ppStr "{- end plain Rec -}")]
+ where
+ ppr_bind (binder, expr)
+ = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
+ 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
+\end{code}
+
+\begin{code}
+pprCoreExpr, pprParendCoreExpr
+ :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+ Outputable bndr,
+ Outputable occ)
+ => PprStyle
+ -> (bndr -> Pretty) -- to print "major" val_bdrs
+ -> (bndr -> Pretty) -- to print "minor" val_bdrs
+ -> (occ -> Pretty) -- to print bindees
+ -> GenCoreExpr bndr occ tyvar uvar
+ -> Pretty
+
+pprCoreExpr sty pbdr1 pbdr2 pocc expr
+ = ppr_expr (initial_pe sty (Left (pbdr1, pbdr2, pocc))) expr
+
+pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
+ = let
+ parenify
+ = case expr of
+ Var _ -> id -- leave unchanged
+ Lit _ -> id
+ _ -> ppParens -- wraps in parens
+ in
+ parenify (pprCoreExpr sty pbdr1 pbdr2 pocc expr)
+
+ppr_core_arg sty pocc arg
+ = ppr_arg (initial_pe sty (Left (pocc, pocc, pocc))) arg
+
+ppr_core_alts sty pbdr1 pbdr2 pocc alts
+ = ppr_alts (initial_pe sty (Left (pbdr1, pbdr2, pocc))) alts
+
+ppr_core_default sty pbdr1 pbdr2 pocc deflt
+ = ppr_default (initial_pe sty (Left (pbdr1, pbdr2, pocc))) deflt
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Instance declarations for Core printing}
+%* *
+%************************************************************************
+
+\begin{code}
+instance
+ (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
+ Eq uvar, Outputable uvar)
+ =>
+ Outputable (GenCoreBinding bndr occ tyvar uvar) where
+ ppr sty bind = pprCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
+
+instance
+ (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
+ Eq uvar, Outputable uvar)
+ =>
+ Outputable (GenCoreExpr bndr occ tyvar uvar) where
+ ppr sty expr = pprCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
+
+instance
+ (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ =>
+ Outputable (GenCoreArg occ tyvar uvar) where
+ ppr sty arg = ppr_core_arg sty (ppr sty) arg
+
+instance
+ (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
+ Eq uvar, Outputable uvar)
+ =>
+ Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
+ ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
+
+instance
+ (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
+ Eq uvar, Outputable uvar)
+ =>
+ Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
+ ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Core printing environment (purely local)}
+%* *
+%************************************************************************
+
+Similar to @VE@ in @PprType@. The ``values'' we print here
+are locally-defined nested-scope names; callers to @pprCoreBinding@,
+etc., can override these.
+
+For tyvars and uvars, we {\em do} normally use these homogenized
+names; for values, we {\em don't}. In printing interfaces, though,
+we use homogenized value names, so that interfaces don't wobble
+uncontrollably from changing Unique-based names.
+
+\begin{code}
+data PrintEnv tyvar uvar bndr occ
+ = PE (Literal -> Pretty) -- Doing these this way saves
+ (DataCon -> Pretty) -- carrying around a PprStyle
+ (PrimOp -> Pretty)
+ (CostCentre -> Pretty)
+
+ [Pretty] -- Tyvar pretty names
+ (tyvar -> Pretty) -- Tyvar lookup function
+ [Pretty] -- Uvar pretty names
+ (uvar -> Pretty) -- Uvar lookup function
+
+ (GenType tyvar uvar -> Pretty)
+ (GenUsage uvar -> Pretty)
+
+ (ValPrinters bndr occ)
+
+data ValPrinters bndr occ
+ = BOPE -- print binders/occs differently
+ (bndr -> Pretty) -- to print "major" val_bdrs
+ (bndr -> Pretty) -- to print "minor" val_bdrs
+ (occ -> Pretty) -- to print bindees
+
+ | VPE -- print all values the same way
+ [Pretty] -- Value pretty names
+ (bndr -> Pretty) -- Binder lookup function
+ (occ -> Pretty) -- Occurrence lookup function
+\end{code}
+
+\begin{code}
+initial_pe :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+ Outputable bndr, Outputable occ)
+ => PprStyle
+ -> Either
+ (bndr -> Pretty, bndr -> Pretty, occ -> Pretty)
+ ()
+ -> PrintEnv tyvar uvar bndr occ
+
+initial_pe sty val_printing
+ = PE (ppr sty) -- for a Literal
+ (ppr sty) -- for a DataCon
+ (ppr sty) -- for a PrimOp
+ (\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre
+
+ tv_pretties ppr_tv -- for a TyVar
+ uv_pretties ppr_uv -- for a UsageVar
+
+ (\ ty -> pprType_Internal sty tv_pretties ppr_tv uv_pretties ppr_uv ty)
+ (ppr sty) -- for a Usage
+
+ val_printing_stuff
+ where
+ ppr_tv = ppr sty -- to print a tyvar
+ ppr_uv = ppr sty -- to print a uvar
+
+ tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
+ ++
+ map (\ n -> ppBeside (ppChar 'a') (ppInt n))
+ ([0 .. ] :: [Int]) -- a0 ... aN
+
+ uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
+ ++
+ map (\ n -> ppBeside (ppChar 'u') (ppInt n))
+ ([0 .. ] :: [Int]) -- u0 ... uN
+
+ val_pretties = map (\ c -> ppChar c ) ['i' .. 'k']
+ ++ map (\ n -> ppBeside (ppChar 'v') (ppInt n))
+ ([0 .. ] :: [Int]) -- v0 ... vN
+
+ ------------------------
+ val_printing_stuff
+ = case val_printing of
+ Left (pbdr1, pbdr2, pocc) -> BOPE pbdr1 pbdr2 pocc
+ Right () -> VPE val_pretties (ppr sty) (ppr sty)
+
+\end{code}
+
+\begin{code}
+plit (PE pp _ _ _ _ _ _ _ _ _ _) = pp
+pcon (PE _ pp _ _ _ _ _ _ _ _ _) = pp
+pprim (PE _ _ pp _ _ _ _ _ _ _ _) = pp
+pscc (PE _ _ _ pp _ _ _ _ _ _ _) = pp
+ptyvar (PE _ _ _ _ _ pp _ _ _ _ _) = pp
+puvar (PE _ _ _ _ _ _ _ pp _ _ _) = pp
+
+pty (PE _ _ _ _ _ _ _ _ pp _ _) = pp
+puse (PE _ _ _ _ _ _ _ _ _ pp _) = pp
+
+pmaj_bdr (PE _ _ _ _ _ _ _ _ _ _ (BOPE pp _ _)) = pp
+pmaj_bdr (PE _ _ _ _ _ _ _ _ _ _ (VPE _ pp _)) = pp
+
+pmin_bdr (PE _ _ _ _ _ _ _ _ _ _ (BOPE _ pp _)) = pp
+pmin_bdr (PE _ _ _ _ _ _ _ _ _ _ (VPE _ pp _)) = pp
+
+pocc (PE _ _ _ _ _ _ _ _ _ _ (BOPE _ _ pp)) = pp
+pocc (PE _ _ _ _ _ _ _ _ _ _ (VPE _ _ pp)) = pp
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Workhorse routines (...????...)}
+%* *
+%************************************************************************
+
+\begin{code}
+ppr_bind pe (NonRec val_bdr expr)
+ = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+ 4 (ppr_expr pe expr)
+
+ppr_bind pe (Rec binds)
+ = ppAboves [ ppStr "{- Rec -}",
+ ppAboves (map ppr_pair binds),
+ ppStr "{- end Rec -}" ]
+ where
+ ppr_pair (val_bdr, expr)
+ = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+ 4 (ppr_expr pe expr)
+\end{code}
+
+\begin{code}
+ppr_parend_expr pe expr
+ = let
+ parenify
+ = case expr of
+ Var _ -> id -- leave unchanged
+ Lit _ -> id
+ _ -> ppParens -- wraps in parens
+ in
+ parenify (ppr_expr pe expr)
+\end{code}
+
+\begin{code}
+ppr_expr pe (Var name) = pocc pe name
+ppr_expr pe (Lit lit) = plit pe lit
+ppr_expr pe (Con con []) = pcon pe con
+
+ppr_expr pe (Con con args)
+ = ppHang (ppBesides [pcon pe con, ppChar '!'])
+ 4 (ppSep (map (ppr_arg pe) args))
+
+ppr_expr pe (Prim prim args)
+ = ppHang (ppBesides [pprim pe prim, ppChar '!'])
+ 4 (ppSep (map (ppr_arg pe) args))
+
+ppr_expr pe expr@(Lam _ _)
+ = let
+ (uvars, tyvars, vars, body) = digForLambdas expr
+ in
+ ppHang (ppCat [pp_vars SLIT("_/u\\_") (puvar pe) uvars,
+ pp_vars SLIT("_/\\_") (ptyvar pe) tyvars,
+ pp_vars SLIT("\\") (pmin_bdr pe) vars])
+ 4 (ppr_expr pe body)
+ where
+ pp_vars lam pp [] = ppNil
+ pp_vars lam pp vs
+ = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
+
+ppr_expr pe expr@(App _ _)
+ = let
+ (fun, args) = collectArgs expr
+ in
+ ppHang (ppr_parend_expr pe fun)
+ 4 (ppSep (map (ppr_arg pe) args))
+
+ppr_expr pe (Case expr alts)
+ = ppSep
+ [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
+ ppNest 2 (ppr_alts pe alts),
+ ppStr "}"]
+
+-- special cases: let ... in let ...
+-- ("disgusting" SLPJ)
+
+ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
+ = ppAboves [
+ ppCat [ppStr "let {", pmaj_bdr pe val_bdr, ppEquals],
+ ppNest 2 (ppr_expr pe rhs),
+ ppStr "} in",
+ ppr_expr pe body ]
+
+ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
+ = ppAbove
+ (ppHang (ppStr "let {")
+ 2 (ppCat [ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+ 4 (ppr_expr pe rhs),
+ ppStr "} in"]))
+ (ppr_expr pe expr)
+
+-- general case (recursive case, too)
+ppr_expr pe (Let bind expr)
+ = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
+ ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
+
+ppr_expr pe (SCC cc expr)
+ = ppSep [ppCat [ppPStr SLIT("_scc_"), pscc pe cc],
+ ppr_parend_expr pe expr ]
+\end{code}
+
+\begin{code}
+ppr_alts pe (AlgAlts alts deflt)
+ = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
+ where
+ ppr_alt (con, params, expr)
+ = ppHang (ppCat [ppr_con con (pcon pe con),
+ ppInterleave ppSP (map (pmin_bdr pe) params),
+ ppStr "->"])
+ 4 (ppr_expr pe expr)
+ where
+ ppr_con con pp_con
+ = if isOpLexeme con then ppParens pp_con else pp_con
+
+ppr_alts pe (PrimAlts alts deflt)
+ = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
+ where
+ ppr_alt (lit, expr)
+ = ppHang (ppCat [plit pe lit, ppStr "->"])
+ 4 (ppr_expr pe expr)
+\end{code}
+
+\begin{code}
+ppr_default pe NoDefault = ppNil
+
+ppr_default pe (BindDefault val_bdr expr)
+ = ppHang (ppCat [pmin_bdr pe val_bdr, ppStr "->"])
+ 4 (ppr_expr pe expr)
+\end{code}
+
+\begin{code}
+ppr_arg pe (LitArg lit) = plit pe lit
+ppr_arg pe (VarArg v) = pocc pe v
+ppr_arg pe (TyArg ty) = pty pe ty
+ppr_arg pe (UsageArg use) = puse pe use
+\end{code}
+
+Other printing bits-and-bobs used with the general @pprCoreBinding@
+and @pprCoreExpr@ functions.
+
+\begin{code}
+pprBigCoreBinder sty binder
+ = ppAboves [sig, pragmas, ppr sty binder]
+ where
+ sig = ifnotPprShowAll sty (
+ ppHang (ppCat [ppr sty binder, ppStr "::"])
+ 4 (ppr sty (idType binder)))
+
+ pragmas =
+ ifnotPprForUser sty
+ (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
+ (getIdInfo binder))
+
+pprBabyCoreBinder sty binder
+ = ppCat [ppr sty binder, pp_strictness]
+ where
+ pp_strictness
+ = case (getIdStrictness binder) of
+ NoStrictnessInfo -> ppNil
+ BottomGuaranteed -> ppStr "{- _!_ -}"
+ StrictnessInfo xx _ ->
+ panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
+ -- ppStr ("{- " ++ (showList xx "") ++ " -}")
+
+pprTypedCoreBinder sty binder
+ = ppBesides [ppLparen, ppCat [ppr sty binder,
+ ppStr "::", ppr sty (idType binder)],
+ ppRparen]
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TaggedCore where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CmdLineOpts(GlobalSwitch)
-import CoreFuns(unTagBinders, unTagBindersAlts)
-import CoreSyn(CoreArg(..), CoreAtom(..), CoreBinding(..), CoreCaseAlternatives(..), CoreCaseDefault(..), CoreExpr(..), applyToArgs, collectArgs, decomposeArgs)
-import CostCentre(CostCentre)
-import Id(Id)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import PrimOps(PrimOp)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique)
-class NamedThing a where
- getExportFlag :: a -> ExportFlag
- isLocallyDefined :: a -> Bool
- getOrigName :: a -> (_PackedString, _PackedString)
- getOccurrenceName :: a -> _PackedString
- getInformingModules :: a -> [_PackedString]
- getSrcLoc :: a -> SrcLoc
- getTheUnique :: a -> Unique
- hasType :: a -> Bool
- getType :: a -> UniType
- fromPreludeCore :: a -> Bool
-class Outputable a where
- ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data BasicLit
-data BinderInfo
-data GlobalSwitch
-data CoreArg a = TypeArg UniType | ValArg (CoreAtom a)
-data CoreAtom a = CoVarAtom a | CoLitAtom BasicLit
-data CoreBinding a b = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)]
-data CoreCaseAlternatives a b = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b)
-data CoreCaseDefault a b = CoNoDefault | CoBindDefault a (CoreExpr a b)
-data CoreExpr a b = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b)
-data CostCentre
-data Id
-data ExportFlag
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data PrimOp
-type SimplifiableBinder = (Id, BinderInfo)
-type SimplifiableCoreAtom = CoreAtom Id
-type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id
-type SimplifiableCoreCaseAlternatives = CoreCaseAlternatives (Id, BinderInfo) Id
-type SimplifiableCoreCaseDefault = CoreCaseDefault (Id, BinderInfo) Id
-type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-data SrcLoc
-type TaggedBinder a = (Id, a)
-type TaggedCoreAtom a = CoreAtom Id
-type TaggedCoreBinding a = CoreBinding (Id, a) Id
-type TaggedCoreCaseAlternatives a = CoreCaseAlternatives (Id, a) Id
-type TaggedCoreCaseDefault a = CoreCaseDefault (Id, a) Id
-type TaggedCoreExpr a = CoreExpr (Id, a) Id
-data TyCon
-data TyVar
-data UniType
-data Unique
-unTagBinders :: CoreExpr (Id, a) b -> CoreExpr Id b
-unTagBindersAlts :: CoreCaseAlternatives (Id, a) b -> CoreCaseAlternatives Id b
-applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b
-collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b])
-decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a])
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable BinderInfo
-instance Outputable Bool
-instance Outputable a => Outputable (CoreArg a)
-instance Outputable a => Outputable (CoreAtom a)
-instance (Outputable a, Outputable b) => Outputable (CoreBinding a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b)
-instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b)
-instance (Outputable a, Outputable b) => Outputable (CoreExpr a b)
-instance Outputable a => Outputable [a]
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TaggedCore]{``Tagged binder'' core syntax (including \tr{Simplifiable*})}
-
-This module defines a particular parameterisation of the @CoreSyntax@
-data type. For ``binders,'' we use a pair: an @Id@ (the actual
-binder) and a ``tag''---any old thing we want to pin on.
-Bindees are @Ids@, as usual.
-
-By far the prevalent use is with a ``tag'' of a @BinderInfo@, as used
-in the simplifier. So we have a full swatch of synonyms for
-\tr{Simplifiable} this and that.
-
-\begin{code}
-#include "HsVersions.h"
-
-module TaggedCore (
- TaggedBinder(..), TaggedCoreBinding(..), TaggedCoreExpr(..),
- TaggedCoreAtom(..), TaggedCoreCaseAlternatives(..),
- TaggedCoreCaseDefault(..),
-#ifdef DPH
- TaggedCoreParQuals(..),
- TaggedCoreParCommunicate(..),
- CoreParCommunicate(..),
- CoreParQuals(..),
-#endif
- unTagBinders, unTagBindersAlts,
-
- CoreArg(..), applyToArgs, decomposeArgs, collectArgs,
-
- SimplifiableBinder(..), SimplifiableCoreBinding(..),
- SimplifiableCoreExpr(..), SimplifiableCoreAtom(..),
- SimplifiableCoreCaseAlternatives(..),
- SimplifiableCoreCaseDefault(..),
-#ifdef DPH
- SimplifiableCoreParQuals(..),
- SimplifiableCoreParCommunicate(..),
-#endif
-
- CoreBinding(..), CoreExpr(..), CoreAtom(..), -- re-exported
- CoreCaseAlternatives(..), CoreCaseDefault(..),
-
- -- and to make the interface self-sufficient ...
- Outputable(..), NamedThing(..),
- ExportFlag, Pretty(..), PprStyle, PrettyRep,
-
- BasicLit, BinderInfo, GlobalSwitch, Id, PrimOp, CostCentre,
- SrcLoc, TyCon, TyVar, UniType, Unique
- ) where
-
-import CoreFuns ( unTagBinders, unTagBindersAlts, digForLambdas )
-import CoreSyn -- mostly re-exporting this stuff
-import BinderInfo ( BinderInfo )
-import Outputable
-import Util
-\end{code}
-
-\begin{code}
-type TaggedBinder tag = (Id, tag)
-
-type TaggedCoreProgram tag = [CoreBinding (TaggedBinder tag) Id]
-type TaggedCoreBinding tag = CoreBinding (TaggedBinder tag) Id
-type TaggedCoreExpr tag = CoreExpr (TaggedBinder tag) Id
-type TaggedCoreAtom tag = CoreAtom Id
-
-#ifdef DPH
-type TaggedCoreParQuals tag = CoreParQuals (TaggedBinder tag) Id
-type TaggedCoreParCommunicate tag
- = CoreParCommunicate (TaggedBinder tag) Id
-#endif {- Data Parallel Haskell -}
-
-type TaggedCoreCaseAlternatives tag = CoreCaseAlternatives (TaggedBinder tag) Id
-type TaggedCoreCaseDefault tag = CoreCaseDefault (TaggedBinder tag) Id
-\end{code}
-
-\begin{code}
-type SimplifiableBinder = (Id, BinderInfo)
-
-type SimplifiableCoreProgram = [CoreBinding SimplifiableBinder Id]
-type SimplifiableCoreBinding = CoreBinding SimplifiableBinder Id
-type SimplifiableCoreExpr = CoreExpr SimplifiableBinder Id
-type SimplifiableCoreAtom = CoreAtom Id
-
-#ifdef DPH
-type SimplifiableCoreParQuals = CoreParQuals SimplifiableBinder Id
-type SimplifiableCoreParCommunicate
- = CoreParCommunicate SimplifiableBinder Id
-#endif {- Data Parallel Haskell -}
-
-type SimplifiableCoreCaseAlternatives = CoreCaseAlternatives SimplifiableBinder Id
-type SimplifiableCoreCaseDefault = CoreCaseDefault SimplifiableBinder Id
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Desugar where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding, CoreExpr)
-import DsMonad(DsMatchContext, DsMatchKind)
-import HsBinds(Bind, Binds, Sig)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import Inst(Inst)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyVar(TyVar)
-import UniType(UniType)
-data Bag a
-data GlobalSwitch
-data SwitchResult
-data CoreBinding a b
-data DsMatchContext
-data DsMatchKind
-data Binds a b
-data Expr a b
-data TypecheckedPat
-data Id
-data SplitUniqSupply
-deSugar :: SplitUniqSupply -> (GlobalSwitch -> SwitchResult) -> _PackedString -> (Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]) -> ([CoreBinding Id Id], Bag DsMatchContext)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Desugar]{@deSugar@: the main function}
\begin{code}
#include "HsVersions.h"
-module Desugar (
- deSugar,
+module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where
- -- and to make the interface self-sufficient...
- SplitUniqSupply, Binds, Expr, Id, TypecheckedPat,
- CoreBinding, GlobalSwitch, SwitchResult,
- Bag, DsMatchContext, DsMatchKind
- ) where
+import Ubiq{-uitous-}
+import HsSyn ( HsBinds, HsExpr )
+import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
+import CoreSyn
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
+import DsMonad
+import DsBinds ( dsBinds, dsInstBinds )
+import DsUtils
-import Bag ( unionBags, Bag )
-import CmdLineOpts ( switchIsOn, GlobalSwitch(..), SwitchResult )
+import Bag ( unionBags )
+import CmdLineOpts ( opt_DoCoreLinting )
import CoreLift ( liftCoreBindings )
import CoreLint ( lintCoreBindings )
-import DsBinds ( dsBinds, dsInstBinds )
-import IdEnv
-import Pretty ( PprStyle(..) )
-import SplitUniq
-import Util
+import Id ( nullIdEnv, mkIdEnv )
+import PprStyle ( PprStyle(..) )
+import UniqSupply ( splitUniqSupply )
\end{code}
-The only trick here is to get the @DesugarMonad@ stuff off to a good
+The only trick here is to get the @DsMonad@ stuff off to a good
start.
\begin{code}
-deSugar :: SplitUniqSupply -- name supply
- -> (GlobalSwitch->SwitchResult) -- switch looker upper
+deSugar :: UniqSupply -- name supply
-> FAST_STRING -- module name
- -> (TypecheckedBinds, -- input: class, instance, and value
- TypecheckedBinds, -- bindings; see "tcModule" (which produces
- TypecheckedBinds, -- them)
- [(Inst, TypecheckedExpr)])
+ -> (TypecheckedHsBinds, -- input: class, instance, and value
+ TypecheckedHsBinds, -- bindings; see "tcModule" (which produces
+ TypecheckedHsBinds, -- them)
+ [(Id, TypecheckedHsExpr)])
-- ToDo: handling of const_inst thingies is certainly WRONG ***************************
- -> ([PlainCoreBinding], -- output
+ -> ([CoreBinding], -- output
Bag DsMatchContext) -- Shadowing complaints
-deSugar us sw_chkr mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs)
+deSugar us mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs)
= let
(us0, us0a) = splitUniqSupply us
(us1, us1a) = splitUniqSupply us0a
(us3, us4) = splitUniqSupply us2a
((core_const_prs, consts_pairs), shadows1)
- = initDs us0 nullIdEnv sw_chkr mod_name (dsInstBinds [] const_inst_pairs)
+ = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs)
consts_env = mkIdEnv consts_pairs
(core_clas_binds, shadows2)
- = initDs us1 consts_env sw_chkr mod_name (dsBinds clas_binds)
+ = initDs us1 consts_env mod_name (dsBinds clas_binds)
core_clas_prs = pairsFromCoreBinds core_clas_binds
-
+
(core_inst_binds, shadows3)
- = initDs us2 consts_env sw_chkr mod_name (dsBinds inst_binds)
+ = initDs us2 consts_env mod_name (dsBinds inst_binds)
core_inst_prs = pairsFromCoreBinds core_inst_binds
-
+
(core_val_binds, shadows4)
- = initDs us3 consts_env sw_chkr mod_name (dsBinds val_binds)
+ = initDs us3 consts_env mod_name (dsBinds val_binds)
core_val_pairs = pairsFromCoreBinds core_val_binds
final_binds
core_clas_binds ++ core_val_binds
else -- gotta make it recursive (sigh)
- [CoRec (core_clas_prs ++ core_inst_prs ++ core_const_prs ++ core_val_pairs)]
+ [Rec (core_clas_prs ++ core_inst_prs ++ core_const_prs ++ core_val_pairs)]
- lift_final_binds = {-if switchIsOn sw_chkr GlasgowExts
- then-} liftCoreBindings us4 final_binds
- -- else final_binds
+ lift_final_binds = liftCoreBindings us4 final_binds
- really_final_binds = if switchIsOn sw_chkr DoCoreLinting
+ really_final_binds = if opt_DoCoreLinting
then lintCoreBindings PprDebug "Desugarer" False lift_final_binds
else lift_final_binds
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsBinds where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding, CoreExpr)
-import DsMonad(DsMatchContext)
-import HsBinds(Binds)
-import HsExpr(Expr)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyVar(TyVar)
-import UniqFM(UniqFM)
-dsBinds :: Binds Id TypecheckedPat -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([CoreBinding Id Id], Bag DsMatchContext)
-dsInstBinds :: [TyVar] -> [(Inst, Expr Id TypecheckedPat)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([(Id, CoreExpr Id Id)], [(Id, CoreExpr Id Id)]), Bag DsMatchContext)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[DsBinds]{Pattern-matching bindings (Binds and MonoBinds)}
+\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
-Handles @Binds@; those at the top level require different handling, in
-that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower
-levels it is preserved with @let@/@letrec@s).
+Handles @HsBinds@; those at the top level require different handling,
+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
+lower levels it is preserved with @let@/@letrec@s).
\begin{code}
#include "HsVersions.h"
-module DsBinds (
- dsBinds, dsInstBinds
- ) where
+module DsBinds ( dsBinds, dsInstBinds ) where
-IMPORT_Trace -- ToDo: rm (debugging only)
+import Ubiq
+import DsLoop -- break dsExpr-ish loop
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
+import HsSyn -- lots of things
+import CoreSyn -- lots of things
+import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
+ TypecheckedBind(..), TypecheckedMonoBinds(..) )
+import DsHsSyn ( collectTypedBinders, collectTypedPatBinders )
-import AbsUniType
-import CmdLineOpts ( GlobalSwitch(..), SwitchResult, switchIsOn )
-import CostCentre ( mkAllDictsCC, preludeDictsCostCentre )
-import Inst ( getInstUniType )
-import DsExpr ( dsExpr )
+import DsMonad
import DsGRHSs ( dsGuarded )
import DsUtils
-import Id ( getIdUniType, mkInstId, Inst, Id, DictVar(..) )
import Match ( matchWrapper )
-import Maybes ( Maybe(..),assocMaybe )
-import Outputable
-import Pretty
-import Util
+
+import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude )
+import CoreUtils ( escErrorMsg )
+import CostCentre ( mkAllDictsCC, preludeDictsCostCentre )
+import Id ( idType, DictVar(..), GenId )
import ListSetOps ( minusList, intersectLists )
+import PprType ( GenType, GenTyVar )
+import PprStyle ( PprStyle(..) )
+import Pretty ( ppShow )
+import Type ( mkTyVarTy, splitSigmaTy )
+import TyVar ( GenTyVar )
+import Unique ( Unique )
+import Util ( isIn, panic )
+
+extractTyVarsFromTy = panic "DsBinds.extractTyVarsFromTy"
+extractTyVarsFromTys = panic "DsBinds.extractTyVarsFromTys"
+isDictTy = panic "DsBinds.isDictTy"
+quantifyTy = panic "DsBinds.quantifyTy"
\end{code}
-
%************************************************************************
%* *
\subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
%* *
%************************************************************************
-Like @dsBinds@, @dsBind@ returns a @[PlainCoreBinding]@, but it may be
+Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
that some of the binders are of unboxed type. This is sorted out when
the caller wraps the bindings round an expression.
\begin{code}
-dsBinds :: TypecheckedBinds -> DsM [PlainCoreBinding]
+dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
\end{code}
All ``real'' bindings are expressed in terms of the
\subsubsection{AbsBind case: no overloading}
%==============================================
-Special case: no overloading.
+Special case: no overloading.
\begin{verbatim}
x1 = e1
x2 = e2
x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
\end{verbatim}
-There are some complications.
+There are some complications.
(i) The @val_binds@ might mention variable not in @local_global_prs@.
In this case we need to make up new polymorphic versions of them.
= mapDs mk_poly_private_binder private_binders
`thenDs` \ poly_private_binders ->
let
- full_local_global_prs = (private_binders `zip` poly_private_binders)
+ full_local_global_prs = (private_binders `zip` poly_private_binders)
++ local_global_prs
in
listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
-- local_global_prs.
private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
binders = collectTypedBinders val_binds
- mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (getIdUniType id)))
+ mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (idType id)))
tyvar_tys = map mkTyVarTy tyvars
\end{code}
letrec f' b = ...(f' b)...
in f' b
-*Notice* that we don't clone type variables, and *do* make use of
+*Notice* that we don't clone type variables, and *do* make use of
shadowing. It is possible to do cloning, but it makes the code quite
a bit more complicated, and the simplifier will clone it all anyway.
dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
= -- If there is any non-overloaded polymorphism, make new locals with
-- appropriate polymorphism
- (if null non_overloaded_tyvars
+ (if null non_overloaded_tyvars
then
-- No non-overloaded polymorphism, so stay with current envt
returnDs (id, [], [])
mapDs mk_binder binders `thenDs` \ new_binders ->
let
old_new_pairs = binders `zip` new_binders
- in
+ in
listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
returnDs (old, app)
| (old,new) <- old_new_pairs
] `thenDs` \ extra_env ->
let
- local_binds = [CoNonRec old app | (old,app) <- extra_env, old `is_elem` locals]
+ local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
is_elem = isIn "dsBinds"
in
returnDs (lookupId old_new_pairs, extra_env, local_binds)
)
`thenDs` \ (binder_subst_fn, local_env, local_binds) ->
-
+
-- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
extendEnvDs local_env (
-
+
dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
extendEnvDs inst_env (
- dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
+ dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
)) `thenDs` \ core_binds ->
let
in
mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
- returnDs [ CoNonRec binder rhs | (binder,rhs) <- core_bind_prs ]
+ returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
where
locals = [local | (local,global) <- local_global_prs]
non_ov_tyvar_tys = map mkTyVarTy non_overloaded_tyvars
- overloaded_tyvars = extractTyVarsFromTys (map getIdUniType dicts)
+ overloaded_tyvars = extractTyVarsFromTys (map idType dicts)
non_overloaded_tyvars = all_tyvars `minusList` overloaded_tyvars
binders = collectTypedBinders val_binds
- mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (getIdUniType id)))
+ mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (idType id)))
\end{code}
@mkSatTyApp id tys@ constructs an expression whose value is (id tys).
However, sometimes id takes more type args than are in tys, and the
specialiser hates that, so we have to eta expand, to
-(/\ a b -> id tys a b)
+@(/\ a b -> id tys a b)@.
\begin{code}
mkSatTyApp :: Id -- Id to apply to the types
- -> [UniType] -- Types to apply it to
- -> DsM PlainCoreExpr
+ -> [Type] -- Types to apply it to
+ -> DsM CoreExpr
-mkSatTyApp id [] = returnDs (CoVar id)
+mkSatTyApp id [] = returnDs (Var id)
mkSatTyApp id tys
- | null tyvar_templates
- = returnDs (mkCoTyApps (CoVar id) tys) -- Common case
-
+ | null tvs
+ = returnDs ty_app -- Common case
| otherwise
- = newTyVarsDs (drop (length tys) tyvar_templates) `thenDs` \ tyvars ->
--- pprTrace "mkSatTyApp:" (ppCat [ppr PprDebug id, ppr PprDebug tyvar_templates, ppr PprDebug tyvars, ppr PprDebug theta, ppr PprDebug tau_ty, ppr PprDebug tys]) $
- returnDs (mkCoTyLam tyvars (mkCoTyApps (mkCoTyApps (CoVar id) tys)
- (map mkTyVarTy tyvars)))
+ = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
+ returnDs (mkTyLam tyvars (mkTyApp ty_app (map mkTyVarTy tyvars)))
where
- (tyvar_templates, theta, tau_ty) = splitType (getIdUniType id)
+ (tvs, theta, tau_ty) = splitSigmaTy (idType id)
+ ty_app = mkTyApp (Var id) tys
\end{code}
-There are several places where we encounter ``inst binds,''
-@(Inst, TypecheckedExpr)@ pairs. Many of these are ``trivial'' binds
+There are several places where we encounter ``inst binds,''
+@(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
(a var to a var or literal), which we want to substitute away; so we
return both some desugared bindings {\em and} a substitution
environment for the subbed-away ones.
\begin{code}
dsInstBinds :: [TyVar] -- Abstract wrt these
- -> [(Inst, TypecheckedExpr)] -- From AbsBinds
- -> DsM ([(Id,PlainCoreExpr)], -- Non-trivial bindings
- [(Id,PlainCoreExpr)]) -- Trivial ones to be substituted away
+ -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
+ -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
+ [(Id,CoreExpr)]) -- Trivial ones to be substituted away
-do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
+do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
dsInstBinds tyvars []
= returnDs do_nothing
-dsInstBinds tyvars ((inst, expr@(Var _)) : bs)
+dsInstBinds _ _ = panic "DsBinds.dsInstBinds:maybe we want something different?"
+
+{- LATER
+
+dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
= dsExpr expr `thenDs` ( \ rhs ->
- let -- Need to apply dsExpr to the variable in case it
+ let -- Need to apply dsExpr to the variable in case it
-- has a substitution in the current environment
- subst_item = (mkInstId inst, rhs)
+ subst_item = (inst, rhs)
in
extendEnvDs [subst_item] (
- dsInstBinds tyvars bs
+ dsInstBinds tyvars bs
) `thenDs` (\ (binds, subst_env) ->
returnDs (binds, subst_item : subst_env)
))
-dsInstBinds tyvars ((inst, expr@(Lit _)) : bs)
+dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
= dsExpr expr `thenDs` ( \ core_lit ->
let
- subst_item = (mkInstId inst, core_lit)
+ subst_item = (inst, core_lit)
in
extendEnvDs [subst_item] (
dsInstBinds tyvars bs
= dsExpr expr `thenDs` \ core_expr ->
ds_dict_cc core_expr `thenDs` \ dict_expr ->
dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
- returnDs ((mkInstId inst, dict_expr) : core_rest, subst_env)
-
+ returnDs ((inst, dict_expr) : core_rest, subst_env)
+
| otherwise
- = -- Obscure case.
+ = -- Obscure case.
-- The inst mentions the type vars wrt which we are abstracting,
-- so we have to invent a new polymorphic version, and substitute
-- appropriately.
- -- This can occur in, for example:
+ -- This can occur in, for example:
-- leftPoll :: [FeedBack a] -> FeedBack a
-- leftPoll xs = take poll xs
-- Here there is an instance of take at the type of elts of xs,
- -- as well as the type of poll.
+ -- as well as the type of poll.
dsExpr expr `thenDs` \ core_expr ->
ds_dict_cc core_expr `thenDs` \ dict_expr ->
newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
let
- subst_item = (mkInstId inst, mkCoTyApps (CoVar poly_inst_id) abs_tys)
+ subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
in
extendEnvDs [subst_item] (
- dsInstBinds tyvars bs
+ dsInstBinds tyvars bs
) `thenDs` \ (core_rest, subst_env) ->
- returnDs ((poly_inst_id, mkCoTyLam abs_tyvars dict_expr) : core_rest,
+ returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
subst_item : subst_env)
where
- inst_ty = getInstUniType inst
+ inst_ty = idType inst
abs_tyvars = extractTyVarsFromTy inst_ty `intersectLists` tyvars
abs_tys = map mkTyVarTy abs_tyvars
(_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
ds_dict_cc expr
= -- if profiling, wrap the dict in "_scc_ DICT <dict>":
- getSwitchCheckerDs `thenDs` \ sw_chkr ->
let
- doing_profiling = sw_chkr SccProfilingOn
- compiling_prelude = sw_chkr CompilingPrelude
+ doing_profiling = opt_SccProfilingOn
+ compiling_prelude = opt_CompilingPrelude
in
if not doing_profiling
|| not (isDictTy inst_ty) then -- that's easy: do nothing
returnDs expr
else if compiling_prelude then
- returnDs (CoSCC prel_dicts_cc expr)
+ returnDs (SCC prel_dicts_cc expr)
else
getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
-- ToDo: do -dicts-all flag (mark dict things
let
dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
in
- returnDs (CoSCC dict_cc expr)
+ returnDs (SCC dict_cc expr)
+-}
\end{code}
%************************************************************************
%* *
%************************************************************************
-Like @dsBinds@, @dsBind@ returns a @[PlainCoreBinding]@, but it may be that
-some of the binders are of unboxed type.
+Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
+some of the binders are of unboxed type.
For an explanation of the first three args, see @dsMonoBinds@.
\begin{code}
dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these
-> (Id -> Id) -- Binder substitution
- -> [(Id,PlainCoreExpr)] -- Inst bindings already dealt with
- -> TypecheckedBind
- -> DsM [PlainCoreBinding]
+ -> [(Id,CoreExpr)] -- Inst bindings already dealt with
+ -> TypecheckedBind
+ -> DsM [CoreBinding]
-dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
- = returnDs [CoNonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
+dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
+ = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
= dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
- returnDs [CoNonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
+ returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
= dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
- returnDs [CoRec (inst_bind_pairs ++ val_bind_pairs)] )
+ returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] )
\end{code}
%* *
%************************************************************************
-@dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @PlainCoreBinds@.
+@dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
In addition to desugaring pattern matching, @dsMonoBinds@ takes
a list of type variables and dicts, and adds abstractions for these
-to the front of every binding. That requires that the
-binders be altered too (their type has changed,
+to the front of every binding. That requires that the
+binders be altered too (their type has changed,
so @dsMonoBinds@ also takes a function which maps binders into binders.
This mapping gives the binder the correct new type.
-> [TyVar] -> [DictVar] -- Abstract wrt these
-> (Id -> Id) -- Binder substitution
-> TypecheckedMonoBinds
- -> DsM [(Id,PlainCoreExpr)]
+ -> DsM [(Id,CoreExpr)]
\end{code}
The extendEnvDs only scopes over the nested call!
Let the simplifier do this.
-dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (Var new_var))
+dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (HsVar new_var))
| not (is_rec || isExported was_var)
- = extendEnvDs [(was_var, CoVar new_var)] (
+ = extendEnvDs [(was_var, Var new_var)] (
returnDs [] )
dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
-}
dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
- = dsExpr expr `thenDs` ( \ core_expr ->
- returnDs [(binder_subst var, mkCoTyLam tyvars (mkCoLam dicts core_expr))] )
+ = dsExpr expr `thenDs` \ core_expr ->
+ returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
\end{code}
\begin{code}
dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
- = putSrcLocDs locn (
+ = putSrcLocDs locn (
let
new_fun = binder_subst fun
in
matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) ->
returnDs [(new_fun,
- mkCoTyLam tyvars (mkCoLam dicts (mkCoLam args body)))]
+ mkLam tyvars (dicts ++ args) body)]
)
where
error_msg fun = "%F" -- "incomplete pattern(s) to match in function \""
++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\""
dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
- = putSrcLocDs locn (
+ = putSrcLocDs locn (
dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
- returnDs [(binder_subst v, mkCoTyLam tyvars (mkCoLam dicts body_expr))]
+ returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
)
\end{code}
pat = rhs
\begin{description}
-\item[pat has no binders.]
+\item[pat has no binders.]
Then all this is dead code and we return an empty binding.
-\item[pat has exactly one binder, v.]
+\item[pat has exactly one binder, v.]
Then we can transform to:
\begin{verbatim}
v' = /\ tyvars -> case rhs of { pat -> v }
vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
\end{verbatim}
\end{description}
-
+
\begin{code}
dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
= putSrcLocDs locn (
-- we can just use the rhs directly
else
-}
- mkSelectorBinds tyvars pat
+ mkSelectorBinds tyvars pat
[(binder, binder_subst binder) | binder <- pat_binders]
body_expr
)
where
pat_binders = collectTypedPatBinders pat
- -- NB For a simple tuple pattern, these binders
+ -- NB For a simple tuple pattern, these binders
-- will appear in the right order!
-
-{- UNUSED, post-Sansom:
- any_con_w_prim_arg :: TypecheckedPat -> Bool
-
- any_con_w_prim_arg (WildPat ty) = isPrimType ty
- any_con_w_prim_arg (VarPat v) = isPrimType (getIdUniType v)
- any_con_w_prim_arg (LazyPat pat) = any_con_w_prim_arg pat
- any_con_w_prim_arg (AsPat _ pat) = any_con_w_prim_arg pat
- any_con_w_prim_arg p@(ConPat _ _ args) = any any_con_w_prim_arg args
- any_con_w_prim_arg (ConOpPat a1 _ a2 _) = any any_con_w_prim_arg [a1,a2]
- any_con_w_prim_arg (ListPat _ args) = any any_con_w_prim_arg args
- any_con_w_prim_arg (TuplePat args) = any any_con_w_prim_arg args
- any_con_w_prim_arg (LitPat _ ty) = isPrimType ty
- any_con_w_prim_arg (NPat _ _ _) = False -- be more paranoid?
- any_con_w_prim_arg (NPlusKPat _ _ _ _ _ _) = False -- ditto
-
-#ifdef DPH
- -- Should be more efficient to find type of pid than pats
- any_con_w_prim_arg (ProcessorPat pats _ pat)
- = error "any_con_w_prim_arg:ProcessorPat (DPH)"
-#endif {- Data Parallel Haskell -}
--}
-
-{- OLD ... removed 6 Feb 95
-
- -- we allow it if the constructor has *only one*
- -- argument and that is unboxed, as in
- --
- -- let (I# i#) = ... in ...
- --
- prim_args args
- = let
- no_of_prim_args
- = length [ a | a <- args, isPrimType (typeOfPat a) ]
- in
- if no_of_prim_args == 0 then
- False
- else if no_of_prim_args == 1 && length args == 1 then
- False -- special case we let through
- else
- True
-
--}
\end{code}
Wild-card patterns could be made acceptable here, but it involves some
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsCCall where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniType(UniType)
-import UniqFM(UniqFM)
-dsCCall :: _PackedString -> [CoreExpr Id Id] -> Bool -> Bool -> UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-
%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
module DsCCall ( dsCCall ) where
-IMPORT_Trace
+import Ubiq
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring
-import DsMonad -- the monadery used in the desugarer
+import CoreSyn
-import AbsPrel
-import TysPrim -- ****** ToDo: PROPERLY
-import TysWiredIn
-import AbsUniType
+import DsMonad
import DsUtils
-import Id ( getInstantiatedDataConSig, mkTupleCon, DataCon(..) )
-import Maybes ( maybeToBool, Maybe(..) )
+
+import CoreUtils ( coreExprType )
+import Id ( getInstantiatedDataConSig, mkTupleCon )
+import Maybes ( maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
+import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo,
+ packStringForCId, realWorldStatePrimTy,
+ realWorldStateTy, realWorldTy, stateDataCon,
+ stringTy )
import Pretty
-#if USE_ATTACK_PRAGMAS
-import Unique
-#endif
-import Util
+import PrimOp ( PrimOp(..) )
+import Type ( isPrimType, maybeAppDataTyCon, eqTy )
+import TyVar ( GenTyVar{-instance-} )
+import Unique ( Unique{-instances-} )
+import Util ( pprPanic, panic )
+
+maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
\end{code}
Desugaring of @ccall@s consists of adding some state manipulation,
available from the type. For each boxed-primitive argument, we
transform:
\begin{verbatim}
- _ccall_ foo [ r, t1, ... tm ] e1 ... em
+ _ccall_ foo [ r, t1, ... tm ] e1 ... em
|
|
V
|
V
\ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
- (StateAnd<r># result# state#) -> (R# result#, realWorld#)
+ (StateAnd<r># result# state#) -> (R# result#, realWorld#)
\end{verbatim}
\begin{code}
dsCCall :: FAST_STRING -- C routine to invoke
- -> [PlainCoreExpr] -- Arguments (desugared)
+ -> [CoreExpr] -- Arguments (desugared)
-> Bool -- True <=> might cause Haskell GC
-> Bool -- True <=> really a "_casm_"
- -> UniType -- Type of the result (a boxed-prim type)
- -> DsM PlainCoreExpr
+ -> Type -- Type of the result (a boxed-prim type)
+ -> DsM CoreExpr
dsCCall label args may_gc is_asm result_ty
= newSysLocalDs realWorldStateTy `thenDs` \ old_s ->
- mapAndUnzipDs unboxArg (CoVar old_s : args) `thenDs` \ (final_args, arg_wrappers) ->
+ mapAndUnzipDs unboxArg (Var old_s : args) `thenDs` \ (final_args, arg_wrappers) ->
boxResult result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
let
the_ccall_op = CCallOp label is_asm may_gc
- (map typeOfCoreExpr final_args)
+ (map coreExprType final_args)
final_result_ty
in
- mkCoPrimDs the_ccall_op
+ mkPrimDs the_ccall_op
[] -- ***NOTE*** no ty apps; the types are inside the_ccall_op.
final_args `thenDs` \ the_prim_app ->
let
the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers
in
- returnDs (CoLam [old_s] the_body)
+ returnDs (Lam (ValBinder old_s) the_body)
where
apply f x = f x
\end{code}
\begin{code}
-unboxArg :: PlainCoreExpr -- The supplied argument
- -> DsM (PlainCoreExpr, -- To pass as the actual argument
- PlainCoreExpr -> PlainCoreExpr -- Wrapper to unbox the arg
+unboxArg :: CoreExpr -- The supplied argument
+ -> DsM (CoreExpr, -- To pass as the actual argument
+ CoreExpr -> CoreExpr -- Wrapper to unbox the arg
)
unboxArg arg
-- Primitive types
-- ADR Question: can this ever be used? None of the PrimTypes are
-- instances of the _CCallable class.
- | isPrimType arg_ty
+ | isPrimType arg_ty
= returnDs (arg, \body -> body)
-- Strings
- | arg_ty == stringTy
+ | arg_ty `eqTy` stringTy
-- ToDo (ADR): - allow synonyms of Strings too?
= newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
- mkCoAppDs (CoVar packStringForCId) arg `thenDs` \ pack_appn ->
- returnDs (CoVar prim_arg,
- \body -> CoCase pack_appn (CoPrimAlts []
- (CoBindDefault prim_arg body))
+ mkAppDs (Var packStringForCId) [] [arg] `thenDs` \ pack_appn ->
+ returnDs (Var prim_arg,
+ \body -> Case pack_appn (PrimAlts []
+ (BindDefault prim_arg body))
)
| null data_cons
-- Byte-arrays, both mutable and otherwise
-- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10]
- | is_data_type &&
+ | is_data_type &&
length data_con_arg_tys == 2 &&
not (isPrimType data_con_arg_ty1) &&
isPrimType data_con_arg_ty2
-- and, of course, it is an instance of _CCallable
--- ( tycon == byteArrayTyCon ||
+-- ( tycon == byteArrayTyCon ||
-- tycon == mutableByteArrayTyCon )
= newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
- returnDs (CoVar arr_cts_var,
- \ body -> CoCase arg (CoAlgAlts [(the_data_con,vars,body)]
- CoNoDefault)
+ returnDs (Var arr_cts_var,
+ \ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
+ NoDefault)
)
-- Data types with a single constructor, which has a single, primitive-typed arg
| maybeToBool maybe_boxed_prim_arg_ty
= newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
- returnDs (CoVar prim_arg,
- \ body -> CoCase arg (CoAlgAlts [(box_data_con,[prim_arg],body)]
- CoNoDefault)
+ returnDs (Var prim_arg,
+ \ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
+ NoDefault)
)
-- ... continued below ....
\end{code}
let
alts = [ (con, [], mkMachInt i) | (con,i) <- data_cons `zip` [0..] ]
- arg_tag = CoCase arg (CoAlgAlts alts) CoNoDefault
+ arg_tag = Case arg (AlgAlts alts) NoDefault
in
- returnDs (CoVar prim_arg,
- \ body -> CoCase arg_tag (CoPrimAlts [(prim_arg, body)] CoNoDefault)
+ returnDs (Var prim_arg,
+ \ body -> Case arg_tag (PrimAlts [(prim_arg, body)] NoDefault)
)
#endif
\end{code}
| otherwise
= pprPanic "unboxArg: " (ppr PprDebug arg_ty)
where
- arg_ty = typeOfCoreExpr arg
+ arg_ty = coreExprType arg
maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
(Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
- maybe_data_type = getUniDataTyCon_maybe arg_ty
+ maybe_data_type = maybeAppDataTyCon arg_ty
is_data_type = maybeToBool maybe_data_type
(Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
(the_data_con : other_data_cons) = data_cons
\begin{code}
tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
-covar_tuple_con_0 = CoVar (mkTupleCon 0) -- ditto
+covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
-boxResult :: UniType -- Type of desired result
- -> DsM (UniType, -- Type of the result of the ccall itself
- PlainCoreExpr -> PlainCoreExpr) -- Wrapper for the ccall
+boxResult :: Type -- Type of desired result
+ -> DsM (Type, -- Type of the result of the ccall itself
+ CoreExpr -> CoreExpr) -- Wrapper for the ccall
-- to box the result
boxResult result_ty
| null data_cons
(null other_data_cons) && -- Just one constr
not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
isPrimType the_prim_result_ty -- of primitive type
- =
+ =
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
- mkCoConDs stateDataCon [realWorldTy] [CoVar prim_state_id] `thenDs` \ new_state ->
- mkCoConDs the_data_con tycon_arg_tys [CoVar prim_result_id] `thenDs` \ the_result ->
-
- mkCoConDs tuple_con_2
- [result_ty, realWorldStateTy]
- [the_result, new_state] `thenDs` \ the_pair ->
+ mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
+ mkConDs the_data_con tycon_arg_tys [Var prim_result_id] `thenDs` \ the_result ->
+
+ mkConDs tuple_con_2
+ [result_ty, realWorldStateTy]
+ [the_result, new_state] `thenDs` \ the_pair ->
let
the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
in
returnDs (state_and_prim_ty,
- \prim_app -> CoCase prim_app (CoAlgAlts [the_alt] CoNoDefault)
+ \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
)
-- Data types with a single nullary constructor
| (maybeToBool maybe_data_type) && -- Data type
(null other_data_cons) && -- Just one constr
(null data_con_arg_tys)
- =
+ =
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
- mkCoConDs stateDataCon [realWorldTy] [CoVar prim_state_id] `thenDs` \ new_state ->
-
- mkCoConDs tuple_con_2
- [result_ty, realWorldStateTy]
- [covar_tuple_con_0, new_state] `thenDs` \ the_pair ->
+ mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
+
+ mkConDs tuple_con_2
+ [result_ty, realWorldStateTy]
+ [covar_tuple_con_0, new_state] `thenDs` \ the_pair ->
let
the_alt = (stateDataCon, [prim_state_id], the_pair)
in
returnDs (realWorldStateTy,
- \prim_app -> CoCase prim_app (CoAlgAlts [the_alt] CoNoDefault)
+ \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
)
#if 0
-- Data types with several nullary constructors (Enumerated types)
| isEnumerationType result_ty && -- Enumeration
(length data_cons) <= 5 -- fairly short
- =
+ =
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
newSysLocalDs intPrimTy `thenDs` \ prim_result_id ->
- mkCoConDs stateDataCon [realWorldTy] [CoVar prim_state_id] `thenDs` \ new_state ->
+ mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
let
alts = [ (mkMachInt i, con) | (i, con) <- [0..] `zip` data_cons ]
- the_result = CoCase prim_result_id (CoPrimAlts alts) CoNoDefault
+ the_result = Case prim_result_id (PrimAlts alts) NoDefault
in
- mkCoConDs (mkTupleCon 2)
+ mkConDs (mkTupleCon 2)
[result_ty, realWorldStateTy]
[the_result, new_state] `thenDs` \ the_pair ->
let
the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
in
returnDs (state_and_prim_ty,
- \prim_app -> CoCase prim_app (CoAlgAlts [the_alt] CoNoDefault)
+ \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
)
#endif
- | otherwise
+ | otherwise
= pprPanic "boxResult: " (ppr PprDebug result_ty)
where
- maybe_data_type = getUniDataTyCon_maybe result_ty
+ maybe_data_type = maybeAppDataTyCon result_ty
Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
(the_data_con : other_data_cons) = data_cons
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsExpr where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import HsExpr(Expr)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniqFM(UniqFM)
-dsExpr :: Expr Id TypecheckedPat -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DsExpr]{Matching expressions (Exprs)}
module DsExpr ( dsExpr ) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
-
-import AbsPrel ( mkTupleTy, unitTy, nilDataCon, consDataCon,
- charDataCon, charTy,
- mkFunTy, mkBuild -- LATER: , foldrId
-#ifdef DPH
- ,fromDomainId, toDomainId
-#endif {- Data Parallel Haskell -}
- )
-import PrimKind ( PrimKind(..) ) -- rather ugly import *** ToDo???
-import AbsUniType ( alpha, alpha_tv, beta, beta_tv, splitType,
- splitTyArgs, mkTupleTyCon, mkTyVarTy, mkForallTy,
- kindFromType, maybeBoxedPrimType,
- TyVarTemplate, TyCon, Arity(..), Class,
- TauType(..), UniType
- )
-import BasicLit ( mkMachInt, BasicLit(..) )
-import CmdLineOpts ( GlobalSwitch(..), SwitchResult, switchIsOn )
-import CostCentre ( mkUserCC )
-import DsBinds ( dsBinds )
+import Ubiq
+import DsLoop -- partly to get dsBinds, partly to chk dsExpr
+
+import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
+ Match, Qual, HsBinds, Stmt, PolyType )
+import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..) )
+import CoreSyn
+
+import DsMonad
import DsCCall ( dsCCall )
import DsListComp ( dsListComp )
-import DsUtils ( mkCoAppDs, mkCoConDs, mkCoPrimDs, dsExprToAtom )
-import Id
-import IdEnv
-import IdInfo
+import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom )
import Match ( matchWrapper )
-import Maybes ( Maybe(..) )
-import TaggedCore ( TaggedBinder(..), unTagBinders )
-import TyVarEnv
-import Util
-
-#ifdef DPH
-import DsParZF ( dsParallelZF )
-#endif {- Data Parallel Haskell -}
+
+import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
+ FormSummary )
+import CoreUtils ( coreExprType, substCoreExpr, argToExpr,
+ mkCoreIfThenElse, unTagBinders )
+import CostCentre ( mkUserCC )
+import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
+ getIdUnfolding )
+import Literal ( mkMachInt, Literal(..) )
+import MagicUFs ( MagicUnfoldingFun )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType, GenTyVar )
+import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
+ charDataCon, charTy )
+import Pretty ( ppShow )
+import Type ( splitSigmaTy )
+import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar )
+import Unique ( Unique )
+import Usage ( UVar(..) )
+import Util ( panic )
+
+primRepFromType = panic "DsExpr.primRepFromType"
+maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
+splitTyArgs = panic "DsExpr.splitTyArgs"
+
+mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility...
\end{code}
The funny business to do with variables is that we look them up in the
%************************************************************************
\begin{code}
-dsExpr :: TypecheckedExpr -> DsM PlainCoreExpr
+dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
-dsExpr (Var var) = dsApp (Var var) []
+dsExpr (HsVar var) = dsApp (HsVar var) []
\end{code}
%************************************************************************
See also below where we look for @DictApps@ for \tr{plusInt}, etc.
\begin{code}
-dsExpr (Lit (StringLit s))
+dsExpr (HsLitOut (HsString s) _)
| _NULL_ s
- = returnDs ( CoCon nilDataCon [charTy] [] )
+ = returnDs (mk_nil_con charTy)
| _LENGTH_ s == 1
= let
- the_char = CoCon charDataCon [] [CoLitAtom (MachChar (_HEAD_ s))]
- the_nil = CoCon nilDataCon [charTy] []
+ the_char = mkCon charDataCon [] [] [LitArg (MachChar (_HEAD_ s))]
+ the_nil = mk_nil_con charTy
in
- mkCoConDs consDataCon [charTy] [the_char, the_nil]
+ mkConDs consDataCon [charTy] [the_char, the_nil]
-- "_" => build (\ c n -> c 'c' n) -- LATER
-- "str" ==> build (\ c n -> foldr charTy T c n "str")
{- LATER:
-dsExpr (Lit (StringLit str)) =
- newTyVarsDs [alpha_tv] `thenDs` \ [new_tyvar] ->
+dsExpr (HsLitOut (HsString str) _) =
+ newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] ->
let
new_ty = mkTyVarTy new_tyvar
in
- newSysLocalsDs [
+ newSysLocalsDs [
charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
new_ty,
- mkForallTy [alpha_tv]
- ((charTy `mkFunTy` (alpha `mkFunTy` alpha))
- `mkFunTy` (alpha `mkFunTy` alpha))
+ mkForallTy [alphaTyVar]
+ ((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy))
+ `mkFunTy` (alphaTy `mkFunTy` alphaTy))
] `thenDs` \ [c,n,g] ->
returnDs (mkBuild charTy new_tyvar c n g (
- foldl CoApp
- (CoTyApp (CoTyApp (CoVar foldrId) charTy) new_ty) *** ensure non-prim type ***
- [CoVarAtom c,CoVarAtom n,CoLitAtom (NoRepStr str)]))
+ foldl App
+ (CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type ***
+ [VarArg c,VarArg n,LitArg (NoRepStr str)]))
-}
-- otherwise, leave it as a NoRepStr;
-- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
-dsExpr (Lit (StringLit str))
- = returnDs (CoLit (NoRepStr str))
+dsExpr (HsLitOut (HsString str) _)
+ = returnDs (Lit (NoRepStr str))
-dsExpr (Lit (LitLitLit s ty))
- = returnDs ( CoCon data_con [] [CoLitAtom (MachLitLit s kind)] )
+dsExpr (HsLitOut (HsLitLit s) ty)
+ = returnDs ( mkCon data_con [] [] [LitArg (MachLitLit s kind)] )
where
(data_con, kind)
= case (maybeBoxedPrimType ty) of
Nothing
-> error ("ERROR: ``literal-literal'' not a single-constructor type: "++ _UNPK_ s ++"; type: "++(ppShow 80 (ppr PprDebug ty)))
Just (boxing_data_con, prim_ty)
- -> (boxing_data_con, kindFromType prim_ty)
+ -> (boxing_data_con, primRepFromType prim_ty)
-dsExpr (Lit (IntLit i))
- = returnDs (CoLit (NoRepInteger i))
+dsExpr (HsLitOut (HsInt i) _)
+ = returnDs (Lit (NoRepInteger i))
-dsExpr (Lit (FracLit r))
- = returnDs (CoLit (NoRepRational r))
+dsExpr (HsLitOut (HsFrac r) _)
+ = returnDs (Lit (NoRepRational r))
-- others where we know what to do:
-dsExpr (Lit (IntPrimLit i))
+dsExpr (HsLitOut (HsIntPrim i) _)
= if (i >= toInteger minInt && i <= toInteger maxInt) then
- returnDs (CoLit (mkMachInt i))
+ returnDs (Lit (mkMachInt i))
else
error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
-dsExpr (Lit (FloatPrimLit f))
- = returnDs (CoLit (MachFloat f))
+dsExpr (HsLitOut (HsFloatPrim f) _)
+ = returnDs (Lit (MachFloat f))
-- ToDo: range checking needed!
-dsExpr (Lit (DoublePrimLit d))
- = returnDs (CoLit (MachDouble d))
+dsExpr (HsLitOut (HsDoublePrim d) _)
+ = returnDs (Lit (MachDouble d))
-- ToDo: range checking needed!
-dsExpr (Lit (CharLit c))
- = returnDs ( CoCon charDataCon [] [CoLitAtom (MachChar c)] )
+dsExpr (HsLitOut (HsChar c) _)
+ = returnDs ( mkCon charDataCon [] [] [LitArg (MachChar c)] )
-dsExpr (Lit (CharPrimLit c))
- = returnDs (CoLit (MachChar c))
+dsExpr (HsLitOut (HsCharPrim c) _)
+ = returnDs (Lit (MachChar c))
-dsExpr (Lit (StringPrimLit s))
- = returnDs (CoLit (MachStr s))
+dsExpr (HsLitOut (HsStringPrim s) _)
+ = returnDs (Lit (MachStr s))
-- end of literals magic. --
-dsExpr expr@(Lam a_Match)
+dsExpr expr@(HsLam a_Match)
= let
error_msg = "%L" --> "pattern-matching failed in lambda"
in
matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) ->
- returnDs ( mkCoLam binders matching_code )
-
-dsExpr expr@(App e1 e2) = dsApp expr []
+ returnDs ( mkValLam binders matching_code )
+dsExpr expr@(HsApp e1 e2) = dsApp expr []
dsExpr expr@(OpApp e1 op e2) = dsApp expr []
\end{code}
\begin{verbatim}
(expr op)
\end{verbatim}
-to
+to
\begin{verbatim}
\x -> op expr x
\end{verbatim}
dsExpr (SectionL expr op)
= dsExpr op `thenDs` \ core_op ->
dsExpr expr `thenDs` \ core_expr ->
- dsExprToAtom core_expr ( \ y_atom ->
+ dsExprToAtom core_expr $ \ y_atom ->
-- for the type of x, we need the type of op's 2nd argument
let
- x_ty = case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) ->
+ x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
case (splitTyArgs tau_ty) of {
((_:arg2_ty:_), _) -> arg2_ty;
- _ -> panic "dsExpr:SectionL:arg 2 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty]))
+ _ -> panic "dsExpr:SectionL:arg 2 ty"
}}
in
newSysLocalDs x_ty `thenDs` \ x_id ->
- returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op y_atom) (CoVarAtom x_id)) ))
+ returnDs (mkValLam [x_id] (core_op `App` y_atom `App` VarArg x_id))
-- dsExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr)
= dsExpr op `thenDs` \ core_op ->
dsExpr expr `thenDs` \ core_expr ->
- dsExprToAtom core_expr (\ y_atom ->
+ dsExprToAtom core_expr $ \ y_atom ->
-- for the type of x, we need the type of op's 1st argument
let
- x_ty = case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) ->
+ x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
case (splitTyArgs tau_ty) of {
((arg1_ty:_), _) -> arg1_ty;
- _ -> panic "dsExpr:SectionR:arg 1 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty]))
+ _ -> panic "dsExpr:SectionR:arg 1 ty"
}}
in
newSysLocalDs x_ty `thenDs` \ x_id ->
- returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op (CoVarAtom x_id)) y_atom) ))
+ returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom))
dsExpr (CCall label args may_gc is_asm result_ty)
= mapDs dsExpr args `thenDs` \ core_args ->
dsCCall label core_args may_gc is_asm result_ty
-- dsCCall does all the unboxification, etc.
-dsExpr (SCC cc expr)
+dsExpr (HsSCC cc expr)
= dsExpr expr `thenDs` \ core_expr ->
getModuleAndGroupDs `thenDs` \ (mod_name, group_name) ->
- returnDs ( CoSCC (mkUserCC cc mod_name group_name) core_expr)
+ returnDs ( SCC (mkUserCC cc mod_name group_name) core_expr)
-dsExpr expr@(Case discrim matches)
- = dsExpr discrim `thenDs` \ core_discrim ->
+dsExpr expr@(HsCase discrim matches src_loc)
+ = putSrcLocDs src_loc $
+ dsExpr discrim `thenDs` \ core_discrim ->
let
error_msg = "%C" --> "pattern-matching failed in case"
in
matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) ->
- returnDs ( mkCoLetAny (CoNonRec discrim_var core_discrim) matching_code )
+ returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
dsExpr (ListComp expr quals)
= dsExpr expr `thenDs` \ core_expr ->
dsListComp core_expr quals
-dsExpr (Let binds expr)
+dsExpr (HsLet binds expr)
= dsBinds binds `thenDs` \ core_binds ->
dsExpr expr `thenDs` \ core_expr ->
returnDs ( mkCoLetsAny core_binds core_expr )
-dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList -- not translated"
+dsExpr (HsDoOut stmts m_id mz_id src_loc)
+ = putSrcLocDs src_loc $
+ panic "dsExpr:HsDoOut"
dsExpr (ExplicitListOut ty xs)
= case xs of
- [] -> returnDs ( CoCon nilDataCon [ty] [] )
+ [] -> returnDs (mk_nil_con ty)
(y:ys) ->
dsExpr y `thenDs` \ core_hd ->
dsExpr (ExplicitListOut ty ys) `thenDs` \ core_tl ->
- mkCoConDs consDataCon [ty] [core_hd, core_tl]
+ mkConDs consDataCon [ty] [core_hd, core_tl]
dsExpr (ExplicitTuple expr_list)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
- mkCoConDs (mkTupleCon (length expr_list))
- (map typeOfCoreExpr core_exprs)
- core_exprs
+ mkConDs (mkTupleCon (length expr_list))
+ (map coreExprType core_exprs)
+ core_exprs
-dsExpr (ExprWithTySig expr sig) = panic "dsExpr: ExprWithTySig"
+dsExpr (RecordCon con rbinds) = panic "dsExpr:RecordCon"
+dsExpr (RecordUpd aexp rbinds) = panic "dsExpr:RecordUpd"
-dsExpr (If guard_expr then_expr else_expr)
- = dsExpr guard_expr `thenDs` \ core_guard ->
+dsExpr (HsIf guard_expr then_expr else_expr src_loc)
+ = putSrcLocDs src_loc $
+ dsExpr guard_expr `thenDs` \ core_guard ->
dsExpr then_expr `thenDs` \ core_then ->
dsExpr else_expr `thenDs` \ core_else ->
returnDs (mkCoreIfThenElse core_guard core_then core_else)
-dsExpr (ArithSeqIn info) = panic "dsExpr.ArithSeqIn"
-
dsExpr (ArithSeqOut expr (From from))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
- mkCoAppDs expr2 from2
+ mkAppDs expr2 [] [from2]
dsExpr (ArithSeqOut expr (FromTo from two))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
dsExpr two `thenDs` \ two2 ->
- mkCoAppDs expr2 from2 `thenDs` \ app1 ->
- mkCoAppDs app1 two2
+ mkAppDs expr2 [] [from2, two2]
dsExpr (ArithSeqOut expr (FromThen from thn))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
dsExpr thn `thenDs` \ thn2 ->
- mkCoAppDs expr2 from2 `thenDs` \ app1 ->
- mkCoAppDs app1 thn2
+ mkAppDs expr2 [] [from2, thn2]
dsExpr (ArithSeqOut expr (FromThenTo from thn two))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
dsExpr thn `thenDs` \ thn2 ->
dsExpr two `thenDs` \ two2 ->
- mkCoAppDs expr2 from2 `thenDs` \ app1 ->
- mkCoAppDs app1 thn2 `thenDs` \ app2 ->
- mkCoAppDs app2 two2
-
-#ifdef DPH
-dsExpr (ParallelZF expr quals)
- = dsParallelZF expr quals
-
-dsExpr (ExplicitPodIn _)
- = panic "dsExpr:ExplicitPodIn -- not translated"
-
-dsExpr (ExplicitPodOut _ _)
- = panic "dsExpr:ExplicitPodOut should remove this."
-
-dsExpr (ExplicitProcessor exprs expr)
- = mapDs dsExpr exprs `thenDs` \ core_exprs ->
- dsExpr expr `thenDs` \ core_expr ->
- mkCoConDs (mkProcessorCon (length exprs))
- ((map typeOfCoreExpr core_exprs)++[typeOfCoreExpr core_expr])
- (core_exprs++[core_expr])
-#endif {- Data Parallel Haskell -}
+ mkAppDs expr2 [] [from2, thn2, two2]
\end{code}
\begin{code}
dsExpr (TyLam tyvars expr)
= dsExpr expr `thenDs` \ core_expr ->
- returnDs( foldr CoTyLam core_expr tyvars)
+ returnDs (mkTyLam tyvars core_expr)
dsExpr expr@(TyApp e tys) = dsApp expr []
\end{code}
\begin{code}
dsExpr (DictLam dictvars expr)
= dsExpr expr `thenDs` \ core_expr ->
- returnDs( mkCoLam dictvars core_expr )
+ returnDs( mkValLam dictvars core_expr )
------------------
\end{verbatim}
\begin{code}
dsExpr (SingleDict dict) -- just a local
- = lookupEnvWithDefaultDs dict (CoVar dict)
+ = lookupEnvWithDefaultDs dict (Var dict)
dsExpr (Dictionary dicts methods)
= -- hey, these things may have been substituted away...
1 -> returnDs (head core_d_and_ms) -- just a single Id
_ -> -- tuple 'em up
- mkCoConDs (mkTupleCon num_of_d_and_ms)
- (map typeOfCoreExpr core_d_and_ms)
- core_d_and_ms
+ mkConDs (mkTupleCon num_of_d_and_ms)
+ (map coreExprType core_d_and_ms)
+ core_d_and_ms
)
where
dicts_and_methods = dicts ++ methods
- dicts_and_methods_exprs = map CoVar dicts_and_methods
+ dicts_and_methods_exprs = map Var dicts_and_methods
num_of_d_and_ms = length dicts_and_methods
dsExpr (ClassDictLam dicts methods expr)
= dsExpr expr `thenDs` \ core_expr ->
case num_of_d_and_ms of
0 -> newSysLocalDs unitTy `thenDs` \ new_x ->
- returnDs (CoLam [new_x] core_expr)
+ returnDs (mkValLam [new_x] core_expr)
1 -> -- no untupling
- returnDs (CoLam dicts_and_methods core_expr)
+ returnDs (mkValLam dicts_and_methods core_expr)
_ -> -- untuple it
newSysLocalDs tuple_ty `thenDs` \ new_x ->
returnDs (
- CoLam [new_x]
- (CoCase (CoVar new_x)
- (CoAlgAlts
+ Lam (ValBinder new_x)
+ (Case (Var new_x)
+ (AlgAlts
[(tuple_con, dicts_and_methods, core_expr)]
- CoNoDefault)))
+ NoDefault)))
where
+ num_of_d_and_ms = length dicts + length methods
dicts_and_methods = dicts ++ methods
- num_of_d_and_ms = length dicts_and_methods
- tuple_ty = mkTupleTy num_of_d_and_ms (map getIdUniType dicts_and_methods)
- tuple_tycon = mkTupleTyCon num_of_d_and_ms
+ tuple_ty = mkTupleTy num_of_d_and_ms (map idType dicts_and_methods)
tuple_con = mkTupleCon num_of_d_and_ms
-cocon_unit = CoCon (mkTupleCon 0) [] [] -- out here to avoid CAF (sigh)
-out_of_range_msg -- ditto
+#ifdef DEBUG
+-- HsSyn constructs that just shouldn't be here:
+dsExpr (HsDo _ _) = panic "dsExpr:HsDo"
+dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList"
+dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
+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}
possible).
\begin{code}
-data DsCoreArg
- = DsTypeArg UniType
- | DsValArg PlainCoreExpr
+type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
-dsApp :: TypecheckedExpr -- expr to desugar
+dsApp :: TypecheckedHsExpr -- expr to desugar
-> [DsCoreArg] -- accumulated ty/val args: NB:
- -> DsM PlainCoreExpr -- final result
+ -> DsM CoreExpr -- final result
-dsApp (App e1 e2) args
+dsApp (HsApp e1 e2) args
= dsExpr e2 `thenDs` \ core_e2 ->
- dsApp e1 (DsValArg core_e2 : args)
+ dsApp e1 (VarArg core_e2 : args)
dsApp (OpApp e1 op e2) args
= dsExpr e1 `thenDs` \ core_e1 ->
dsExpr e2 `thenDs` \ core_e2 ->
- dsApp op (DsValArg core_e1 : DsValArg core_e2 : args)
+ dsApp op (VarArg core_e1 : VarArg core_e2 : args)
dsApp (DictApp expr dicts) args
= -- now, those dicts may have been substituted away...
- zipWithDs lookupEnvWithDefaultDs dicts (map CoVar dicts)
+ zipWithDs lookupEnvWithDefaultDs dicts (map Var dicts)
`thenDs` \ core_dicts ->
- dsApp expr (map DsValArg core_dicts ++ args)
+ dsApp expr (map VarArg core_dicts ++ args)
dsApp (TyApp expr tys) args
- = dsApp expr (map DsTypeArg tys ++ args)
+ = dsApp expr (map TyArg tys ++ args)
-- we might should look out for SectionLs, etc., here, but we don't
-dsApp (Var v) args
+dsApp (HsVar v) args
= lookupEnvDs v `thenDs` \ maybe_expr ->
case maybe_expr of
Just expr -> apply_to_args expr args
Nothing -> -- we're only saturating constructors and PrimOps
case getIdUnfolding v of
- GeneralForm _ _ the_unfolding EssentialUnfolding
+ GenForm _ _ the_unfolding EssentialUnfolding
-> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
- _ -> apply_to_args (CoVar v) args
+ _ -> apply_to_args (Var v) args
dsApp anything_else args
= dsExpr anything_else `thenDs` \ core_expr ->
apply_to_args core_expr args
--- a DsM version of applyToArgs:
-apply_to_args :: PlainCoreExpr -> [DsCoreArg] -> DsM PlainCoreExpr
-
-apply_to_args fun [] = returnDs fun
-
-apply_to_args fun (DsValArg expr : args)
- = mkCoAppDs fun expr `thenDs` \ fun2 ->
- apply_to_args fun2 args
+-- a DsM version of mkGenApp:
+apply_to_args :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
-apply_to_args fun (DsTypeArg ty : args)
- = apply_to_args (mkCoTyApp fun ty) args
+apply_to_args fun args
+ = let
+ (ty_args, val_args) = foldr sep ([],[]) args
+ in
+ mkAppDs fun ty_args val_args
+ where
+ sep a@(LitArg l) (tys,vals) = (tys, (Lit l):vals)
+ sep a@(VarArg e) (tys,vals) = (tys, e:vals)
+ sep a@(TyArg ty) (tys,vals) = (ty:tys, vals)
+ sep a@(UsageArg _) _ = panic "DsExpr:apply_to_args:UsageArg"
\end{code}
\begin{code}
-do_unfold ty_env val_env (CoTyLam tyvar body) (DsTypeArg ty : args)
+do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
= do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
-do_unfold ty_env val_env (CoLam [] body) args
- = do_unfold ty_env val_env body args
-
-do_unfold ty_env val_env (CoLam (binder:binders) body) (DsValArg expr : args)
- = dsExprToAtom expr (\ arg_atom ->
- do_unfold ty_env (addOneToIdEnv val_env binder (atomToExpr arg_atom)) (CoLam binders body) args
- )
+do_unfold ty_env val_env (Lam (ValBinder binder) body) (VarArg expr : args)
+ = dsExprToAtom expr $ \ arg_atom ->
+ do_unfold ty_env
+ (addOneToIdEnv val_env binder (argToExpr arg_atom))
+ body args
do_unfold ty_env val_env body args
= -- Clone the remaining part of the template
- uniqSMtoDsM (substCoreExprUS val_env ty_env body) `thenDs` \ body' ->
+ uniqSMtoDsM (substCoreExpr val_env ty_env body) `thenDs` \ body' ->
-- Apply result to remaining arguments
apply_to_args body' args
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsGRHSs where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext, DsMatchKind)
-import DsUtils(MatchResult)
-import HsMatches(GRHS, GRHSsAndBinds)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniType(UniType)
-import UniqFM(UniqFM)
-dsGRHSs :: UniType -> DsMatchKind -> [TypecheckedPat] -> [GRHS Id TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-dsGuarded :: GRHSsAndBinds Id TypecheckedPat -> SrcLoc -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-
module DsGRHSs ( dsGuarded, dsGRHSs ) where
+import Ubiq
+import DsLoop -- break dsExpr/dsBinds-ish loop
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
-
-import AbsPrel ( stringTy
- IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
- )
-import DsBinds ( dsBinds )
-import DsExpr ( dsExpr )
+import HsSyn ( GRHSsAndBinds(..), GRHS(..),
+ HsExpr, HsBinds )
+import TcHsSyn ( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
+ TypecheckedPat(..), TypecheckedHsBinds(..),
+ TypecheckedHsExpr(..) )
+import CoreSyn ( CoreBinding(..), CoreExpr(..) )
+
+import DsMonad
import DsUtils
-import Pretty
-import Util
+
+import CoreUtils ( escErrorMsg, mkErrorApp )
+import PrelInfo ( stringTy )
+import PprStyle ( PprStyle(..) )
+import Pretty ( ppShow )
+import SrcLoc ( SrcLoc{-instance-} )
+import Util ( panic )
+
+mkCoLetsAny = panic "DsGRHSs.mkCoLetsAny"
+mkCoreIfThenElse = panic "DsGRHSs.mkCoreIfThenElse"
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
\begin{code}
dsGuarded :: TypecheckedGRHSsAndBinds
-> SrcLoc
- -> DsM PlainCoreExpr
+ -> DsM CoreExpr
dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc
= dsBinds binds `thenDs` \ core_binds ->
where
unencoded_part_of_msg = escErrorMsg (ppShow 80 (ppr PprForUser err_loc))
- error_expr :: Id -> PlainCoreExpr
- error_expr str_var = mkErrorCoApp err_ty str_var
+ error_expr :: Id -> CoreExpr
+ error_expr str_var = mkErrorApp err_ty str_var
(unencoded_part_of_msg
++ "%N") --> ": non-exhaustive guards"
\end{code}
...
| gm = em
\end{verbatim}
-We supply a @PlainCoreExpr@ for the case in which all of
+We supply a @CoreExpr@ for the case in which all of
the guards fail.
\begin{code}
-dsGRHSs :: UniType -- Type of RHSs
+dsGRHSs :: Type -- Type of RHSs
-> DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
-> [TypecheckedGRHS] -- Guarded RHSs
-> DsM MatchResult
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[DsHsSyn]{Haskell abstract syntax---added things for desugarer}
+
+\begin{code}
+#include "HsVersions.h"
+
+module DsHsSyn where
+
+import Ubiq
+
+import HsSyn ( OutPat(..), HsBinds(..), Bind(..), MonoBinds(..),
+ Sig, HsExpr, GRHSsAndBinds, Match, HsLit )
+import TcHsSyn ( TypecheckedPat(..), TypecheckedBind(..),
+ TypecheckedMonoBinds(..) )
+
+import Id ( idType )
+import PrelInfo ( mkListTy, mkTupleTy, unitTy )
+import Util ( panic )
+\end{code}
+
+Note: If @outPatType@ doesn't bear a strong resemblance to @coreExprType@,
+then something is wrong.
+\begin{code}
+outPatType :: TypecheckedPat -> Type
+
+outPatType (WildPat ty) = ty
+outPatType (VarPat var) = idType var
+outPatType (LazyPat pat) = outPatType pat
+outPatType (AsPat var pat) = idType var
+outPatType (ConPat _ ty _) = ty
+outPatType (ConOpPat _ _ _ ty) = ty
+outPatType (ListPat ty _) = mkListTy ty
+outPatType (TuplePat pats) = mkTupleTy (length pats) (map outPatType pats)
+outPatType (LitPat lit ty) = ty
+outPatType (NPat lit ty _) = ty
+outPatType (DictPat ds ms) = case (length ds + length ms) of
+ 0 -> unitTy
+ 1 -> idType (head (ds ++ ms))
+ n -> mkTupleTy n (map idType (ds ++ ms))
+\end{code}
+
+
+Nota bene: DsBinds relies on the fact that at least for simple
+tuple patterns @collectTypedPatBinders@ returns the binders in
+the same order as they appear in the tuple.
+
+collectTypedBinders and collectedTypedPatBinders are the exportees.
+
+\begin{code}
+collectTypedBinders :: TypecheckedBind -> [Id]
+collectTypedBinders EmptyBind = []
+collectTypedBinders (NonRecBind bs) = collectTypedMonoBinders bs
+collectTypedBinders (RecBind bs) = collectTypedMonoBinders bs
+
+collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
+collectTypedMonoBinders EmptyMonoBinds = []
+collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
+collectTypedMonoBinders (FunMonoBind f _ _) = [f]
+collectTypedMonoBinders (VarMonoBind v _) = [v]
+collectTypedMonoBinders (AndMonoBinds bs1 bs2)
+ = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
+
+collectTypedPatBinders :: TypecheckedPat -> [Id]
+collectTypedPatBinders (VarPat var) = [var]
+collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
+collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
+collectTypedPatBinders (ConPat _ _ pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (ConOpPat p1 _ p2 _) = collectTypedPatBinders p1 ++ collectTypedPatBinders p2
+collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (TuplePat pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (DictPat ds ms) = ds ++ ms
+collectTypedPatBinders any_other_pat = [ {-no binders-} ]
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsListComp where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import HsExpr(Qual)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniqFM(UniqFM)
-dsListComp :: CoreExpr Id Id -> [Qual Id TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DsListComp]{Desugaring list comprehensions}
\begin{code}
module DsListComp ( dsListComp ) where
+import Ubiq
+import DsLoop -- break dsExpr-ish loop
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
+import HsSyn ( Qual(..), HsExpr, HsBinds )
+import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) )
+import DsHsSyn ( outPatType )
+import CoreSyn
-import AbsPrel ( mkFunTy, nilDataCon, consDataCon, listTyCon,
- mkBuild, mkFoldr
- )
-import AbsUniType ( alpha_tv, alpha, mkTyVarTy, mkForallTy )
-import CmdLineOpts ( GlobalSwitch(..) )
-import DsExpr ( dsExpr )
+import DsMonad -- the monadery used in the desugarer
import DsUtils
-import Id ( getIdInfo, replaceIdInfo )
-import IdInfo
+
+import CmdLineOpts ( opt_FoldrBuildOn )
+import CoreUtils ( coreExprType, mkCoreIfThenElse )
+import PrelInfo ( nilDataCon, consDataCon, listTyCon,
+ mkBuild, foldrId )
+import Type ( mkTyVarTy, mkForAllTy, mkFunTys )
+import TysPrim ( alphaTy )
+import TyVar ( alphaTyVar )
import Match ( matchSimply )
-import Util
+import Util ( panic )
\end{code}
List comprehensions may be desugared in one of two ways: ``ordinary''
There will be at least one ``qualifier'' in the input.
\begin{code}
-dsListComp :: PlainCoreExpr -> [TypecheckedQual] -> DsM PlainCoreExpr
+dsListComp :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr
dsListComp expr quals
- = let expr_ty = typeOfCoreExpr expr
+ = let
+ expr_ty = coreExprType expr
in
- ifSwitchSetDs FoldrBuildOn (
+ if not opt_FoldrBuildOn then -- be boring
+ deListComp expr quals (nIL_EXPR expr_ty)
+
+ else -- foldr/build lives!
new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) ->
let
- c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
- g_ty = mkForallTy [alpha_tv] (
- (expr_ty `mkFunTy` (alpha `mkFunTy` alpha))
- `mkFunTy` (alpha `mkFunTy` alpha))
+ alpha_to_alpha = mkFunTys [alphaTy] alphaTy
+
+ c_ty = mkFunTys [expr_ty, n_ty] n_ty
+ g_ty = mkForAllTy alphaTyVar (
+ (mkFunTys [expr_ty, alpha_to_alpha] alpha_to_alpha))
in
- newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] ->
+ newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] ->
dfListComp expr expr_ty
- c_ty c
+ c_ty c
n_ty n
quals `thenDs` \ result ->
returnDs (mkBuild expr_ty n_tyvar c n g result)
-
- ) {-else be boring-} (
- deListComp expr quals (nIL_EXPR expr_ty)
- )
where
- nIL_EXPR ty = CoCon nilDataCon [ty] []
+ nIL_EXPR ty = mkCon nilDataCon [] [ty] []
- new_alpha_tyvar :: DsM (TyVar, UniType)
+ new_alpha_tyvar :: DsM (TyVar, Type)
new_alpha_tyvar
- = newTyVarsDs [alpha_tv] `thenDs` \ [new_ty] ->
+ = newTyVarsDs [alphaTyVar] `thenDs` \ [new_ty] ->
returnDs (new_ty,mkTyVarTy new_ty)
\end{code}
already desugared. @dsListComp@ does the top TE rule mentioned above.
\begin{code}
-deListComp :: PlainCoreExpr -> [TypecheckedQual] -> PlainCoreExpr -> DsM PlainCoreExpr
+deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr
deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above
- = mkCoConDs consDataCon [typeOfCoreExpr expr] [expr, list]
+ = mkConDs consDataCon [coreExprType expr] [expr, list]
-deListComp expr ((FilterQual filt): quals) list -- rule B above
+deListComp expr (FilterQual filt : quals) list -- rule B above
= dsExpr filt `thenDs` \ core_filt ->
deListComp expr quals list `thenDs` \ core_rest ->
returnDs ( mkCoreIfThenElse core_filt core_rest list )
+deListComp expr (LetQual binds : quals) list
+ = panic "deListComp:LetQual"
+
deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
= dsExpr list1 `thenDs` \ core_list1 ->
let
- u3_ty@u1_ty = typeOfCoreExpr core_list1 -- two names, same thing
+ u3_ty@u1_ty = coreExprType core_list1 -- two names, same thing
-- u1_ty is a [alpha] type, and u2_ty = alpha
- u2_ty = typeOfPat pat
-
- res_ty = typeOfCoreExpr core_list2
- h_ty = mkFunTy u1_ty res_ty
+ u2_ty = outPatType pat
+
+ res_ty = coreExprType core_list2
+ h_ty = mkFunTys [u1_ty] res_ty
in
newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
`thenDs` \ [h', u1, u2, u3] ->
Since it only occurs once in the body, we can't get
an increase in code size by unfolding it.
-}
--- getSwitchCheckerDs `thenDs` \ sw_chkr ->
let
h = if False -- LATER: sw_chkr DoDeforest???
- then replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
+ then panic "deListComp:deforest"
+ -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
else h'
in
-- the "fail" value ...
- mkCoAppDs (CoVar h) (CoVar u3) `thenDs` \ core_fail ->
+ mkAppDs (Var h) [] [Var u3] `thenDs` \ core_fail ->
deListComp expr quals core_fail `thenDs` \ rest_expr ->
- matchSimply (CoVar u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
+ matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
- mkCoAppDs (CoVar h) core_list1 `thenDs` \ letrec_body ->
+ mkAppDs (Var h) [] [core_list1] `thenDs` \ letrec_body ->
returnDs (
mkCoLetrecAny [
( h,
- (CoLam [ u1 ]
- (CoCase (CoVar u1)
- (CoAlgAlts
+ (Lam (ValBinder u1)
+ (Case (Var u1)
+ (AlgAlts
[(nilDataCon, [], core_list2),
(consDataCon, [u2, u3], core_match)]
- CoNoDefault)))
+ NoDefault)))
)] letrec_body
)
\end{code}
\begin{verbatim}
TE < [ e | ] >> c n = c e n
TE << [ e | b , q ] >> c n = if b then TE << [ e | q ] >> c n else n
-TE << [ e | p <- l , q ] c n = foldr
- (\ TE << p >> b -> TE << [ e | q ] >> c b
+TE << [ e | p <- l , q ] c n = foldr
+ (\ TE << p >> b -> TE << [ e | q ] >> c b
_ b -> b) n l
\end{verbatim}
\begin{code}
-dfListComp :: PlainCoreExpr -- the inside of the comp
- -> UniType -- the type of the inside
- -> UniType -> Id -- 'c'; its type and id
- -> UniType -> Id -- 'n'; its type and id
+dfListComp :: CoreExpr -- the inside of the comp
+ -> Type -- the type of the inside
+ -> Type -> Id -- 'c'; its type and id
+ -> Type -> Id -- 'n'; its type and id
-> [TypecheckedQual] -- the rest of the qual's
- -> DsM PlainCoreExpr
+ -> DsM CoreExpr
-dfListComp expr expr_ty c_ty c_id n_ty n_id []
- = mkCoAppDs (CoVar c_id) expr `thenDs` \ inner ->
- mkCoAppDs inner (CoVar n_id)
+dfListComp expr expr_ty c_ty c_id n_ty n_id []
+ = mkAppDs (Var c_id) [] [expr, Var n_id]
-dfListComp expr expr_ty c_ty c_id n_ty n_id ((FilterQual filt) : quals)
+dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals)
= dsExpr filt `thenDs` \ core_filt ->
dfListComp expr expr_ty c_ty c_id n_ty n_id quals
`thenDs` \ core_rest ->
- returnDs (mkCoreIfThenElse core_filt core_rest (CoVar n_id))
+ returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id))
-dfListComp expr expr_ty c_ty c_id n_ty n_id ((GeneratorQual pat list1):quals)
+dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals)
+ = panic "dfListComp:LetQual"
+
+dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals)
-- evaluate the two lists
= dsExpr list1 `thenDs` \ core_list1 ->
-- find the required type
- let p_ty = typeOfPat pat
- b_ty = n_ty -- alias b_ty to n_ty
- fn_ty = p_ty `mkFunTy` (b_ty `mkFunTy` b_ty)
- lst_ty = typeOfCoreExpr core_list1
+ let p_ty = outPatType pat
+ b_ty = n_ty -- alias b_ty to n_ty
+ fn_ty = mkFunTys [p_ty, b_ty] b_ty
+ lst_ty = coreExprType core_list1
in
-- create some new local id's
dfListComp expr expr_ty c_ty c_id b_ty b quals `thenDs` \ core_rest ->
-- build the pattern match
- matchSimply (CoVar p) pat b_ty core_rest (CoVar b) `thenDs` \ core_expr ->
+ matchSimply (Var p) pat b_ty core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
returnDs (
mkCoLetsAny
- [CoNonRec fn (CoLam [p,b] core_expr),
- CoNonRec lst core_list1]
+ [NonRec fn (mkValLam [p, b] core_expr),
+ NonRec lst core_list1]
(mkFoldr p_ty n_ty fn n_id lst)
)
-\end{code}
+mkFoldr a b f z xs
+ = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]
+\end{code}
--- /dev/null
+Break the loop between Match and DsUtils and the loops
+between DsExpr/DsBinds and various things.
+
+\begin{code}
+interface DsLoop where
+
+import CoreSyn ( CoreBinding(..), CoreExpr(..) )
+import DsMonad ( DsM(..) )
+import DsBinds ( dsBinds )
+import DsExpr ( dsExpr )
+import DsUtils ( EquationInfo, MatchResult )
+import Id ( Id(..) )
+import Match ( match, matchSimply )
+import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..), TypecheckedPat(..) )
+import Type ( Type(..) )
+
+match :: [Id] -- Variables rep'ing the exprs we're matching with
+ -> [EquationInfo] -- Info about patterns, etc. (type synonym below)
+ -> [EquationInfo] -- Potentially shadowing equations above this one
+ -> DsM MatchResult -- Desugared result!
+
+matchSimply :: CoreExpr -- Scrutinee
+ -> TypecheckedPat -- Pattern it should match
+ -> Type -- Type of result
+ -> CoreExpr -- Return this if it matches
+ -> CoreExpr -- Return this if it does
+ -> DsM CoreExpr
+
+dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
+dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsMonad where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import HsPat(TypecheckedPat)
-import Id(DataCon(..), Id)
-import Maybes(Labda)
-import PlainCore(PlainCoreExpr(..))
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import UniqFM(UniqFM)
-import Unique(UniqSM(..), UniqueSupply)
-infixr 9 `thenDs`
-data GlobalSwitch
-data SwitchResult
-data CoreExpr a b
-type DataCon = Id
-type DsIdEnv = UniqFM (CoreExpr Id Id)
-type DsM a = SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-data DsMatchContext = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext
-data DsMatchKind = FunMatch Id | CaseMatch | LambdaMatch | PatBindMatch
-data Id
-type PlainCoreExpr = CoreExpr Id Id
-data SplitUniqSupply
-data SrcLoc
-data TyVar
-data TyVarTemplate
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType
-type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-andDs :: (a -> a -> a) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-cloneTyVarsDs :: [TyVar] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([TyVar], Bag DsMatchContext)
-dsShadowError :: DsMatchContext -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((), Bag DsMatchContext)
-duplicateLocalDs :: Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext)
-extendEnvDs :: [(Id, CoreExpr Id Id)] -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-getModuleAndGroupDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((_PackedString, _PackedString), Bag DsMatchContext)
-getSrcLocDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([Char], [Char]), Bag DsMatchContext)
-getSwitchCheckerDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (GlobalSwitch -> Bool, Bag DsMatchContext)
-ifSwitchSetDs :: GlobalSwitch -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-initDs :: SplitUniqSupply -> UniqFM (CoreExpr Id Id) -> (GlobalSwitch -> SwitchResult) -> _PackedString -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (a, Bag DsMatchContext)
-listDs :: [SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([a], Bag DsMatchContext)
-lookupEnvDs :: Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Labda (CoreExpr Id Id), Bag DsMatchContext)
-lookupEnvWithDefaultDs :: Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-lookupId :: [(Id, a)] -> Id -> a
-mapAndUnzipDs :: (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((b, c), Bag DsMatchContext)) -> [a] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([b], [c]), Bag DsMatchContext)
-mapDs :: (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)) -> [a] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([b], Bag DsMatchContext)
-newFailLocalDs :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext)
-newSysLocalDs :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext)
-newSysLocalsDs :: [UniType] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([Id], Bag DsMatchContext)
-newTyVarsDs :: [TyVarTemplate] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([TyVar], Bag DsMatchContext)
-pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Int -> Bool -> PrettyRep
-putSrcLocDs :: SrcLoc -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-returnDs :: a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-thenDs :: (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)
-uniqSMtoDsM :: (UniqueSupply -> (UniqueSupply, a)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
-zipWithDs :: (a -> b -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (c, Bag DsMatchContext)) -> [a] -> [b] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([c], Bag DsMatchContext)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[DesugarMonad]{@DesugarMonad@: monadery used in desugaring}
+\section[DsMonad]{@DsMonad@: monadery used in desugaring}
\begin{code}
#include "HsVersions.h"
duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
newFailLocalDs,
getSrcLocDs, putSrcLocDs,
- getSwitchCheckerDs, ifSwitchSetDs,
getModuleAndGroupDs,
extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
DsIdEnv(..),
lookupId,
dsShadowError,
- DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
-
-#ifdef DPH
- listDs,
-#endif
-
- -- and to make the interface self-sufficient...
- Id, DataCon(..), SrcLoc, TyVar, TyVarTemplate, UniType, TauType(..),
- ThetaType(..), SigmaType(..), SplitUniqSupply, UniqSM(..),
- PlainCoreExpr(..), CoreExpr, GlobalSwitch, SwitchResult
-
- IF_ATTACK_PRAGMAS(COMMA lookupUFM COMMA lookupIdEnv)
- IF_ATTACK_PRAGMAS(COMMA mkIdWithNewUniq COMMA mkSysLocal)
- IF_ATTACK_PRAGMAS(COMMA unpackSrcLoc COMMA mkUniqueSupplyGrimily)
- IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
- IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique)
+ DsMatchContext(..), DsMatchKind(..), pprDsWarnings
) where
-import AbsSyn
-import AbsUniType ( cloneTyVarFromTemplate, cloneTyVar,
- TyVar, TyVarTemplate, UniType, TauType(..),
- ThetaType(..), SigmaType(..), Class
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- )
-import Bag
-import CmdLineOpts -- ( GlobalSwitch(..), SwitchResult(..), switchIsOn )
-import Id ( mkIdWithNewUniq, mkSysLocal, Id, DataCon(..) )
-import IdEnv -- ( mkIdEnv, IdEnv )
-import Maybes ( assocMaybe, Maybe(..) )
-import Outputable
-import PlainCore
+import Ubiq
+
+import Bag ( emptyBag, snocBag, bagToList )
+import CmdLineOpts ( opt_SccGroup )
+import CoreSyn ( CoreExpr(..) )
+import CoreUtils ( substCoreExpr )
+import HsSyn ( OutPat )
+import Id ( mkSysLocal, lookupIdEnv, growIdEnvList, GenId, IdEnv(..) )
+import PprType ( GenType, GenTyVar )
+import PprStyle ( PprStyle(..) )
import Pretty
import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import TyVarEnv -- ( nullTyVarEnv, TyVarEnv )
-import SplitUniq
-import Unique
-import Util
+import TcHsSyn ( TypecheckedPat(..) )
+import TyVar ( nullTyVarEnv, GenTyVar )
+import Unique ( Unique{-instances-} )
+import UniqSupply ( splitUniqSupply, getUnique, getUniques,
+ mapUs, thenUs, returnUs, UniqSM(..) )
+import Unique ( Unique )
+import Util ( assoc, mapAccumL, zipWithEqual, panic )
infixr 9 `thenDs`
+
+cloneTyVar = panic "DsMonad.cloneTyVar"
+cloneTyVarFromTemplate = panic "DsMonad.cloneTyVarFromTemplate"
+mkIdWithNewUniq = panic "DsMonad.mkIdWithNewUniq"
\end{code}
Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
presumably include source-file location information:
\begin{code}
type DsM result =
- SplitUniqSupply
- -> SrcLoc -- to put in pattern-matching error msgs
- -> (GlobalSwitch -> SwitchResult) -- so we can consult global switches
- -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling
+ UniqSupply
+ -> SrcLoc -- to put in pattern-matching error msgs
+ -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling
-> DsIdEnv
-> DsWarnings
-> (result, DsWarnings)
-type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are
+type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are
-- completely shadowed
-
-#ifdef __GLASGOW_HASKELL__
{-# INLINE andDs #-}
{-# INLINE thenDs #-}
{-# INLINE returnDs #-}
-#endif
-- initDs returns the UniqSupply out the end (not just the result)
-initDs :: SplitUniqSupply
+initDs :: UniqSupply
-> DsIdEnv
- -> (GlobalSwitch -> SwitchResult)
-> FAST_STRING -- module name: for profiling; (group name: from switches)
-> DsM a
-> (a, DsWarnings)
-initDs init_us env sw_chkr mod_name action
- = action init_us mkUnknownSrcLoc sw_chkr module_and_group env emptyBag
+initDs init_us env mod_name action
+ = action init_us mkUnknownSrcLoc module_and_group env emptyBag
where
module_and_group = (mod_name, grp_name)
- grp_name = case (stringSwitchSet sw_chkr SccGroup) of
- Just xx -> _PK_ xx
+ grp_name = case opt_SccGroup of
+ Just xx -> xx
Nothing -> mod_name -- default: module name
thenDs :: DsM a -> (a -> DsM b) -> DsM b
andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
-thenDs expr cont us loc sw_chkr mod_and_grp env warns
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr s1 loc sw_chkr mod_and_grp env warns) of { (result, warns1) ->
- cont result s2 loc sw_chkr mod_and_grp env warns1}}
+thenDs m1 m2 us loc mod_and_grp env warns
+ = case splitUniqSupply us of { (s1, s2) ->
+ case (m1 s1 loc mod_and_grp env warns) of { (result, warns1) ->
+ m2 result s2 loc mod_and_grp env warns1}}
-andDs combiner m1 m2 us loc sw_chkr mod_and_grp env warns
- = case splitUniqSupply us of { (s1, s2) ->
- case (m1 s1 loc sw_chkr mod_and_grp env warns) of { (result1, warns1) ->
- case (m2 s2 loc sw_chkr mod_and_grp env warns1) of { (result2, warns2) ->
+andDs combiner m1 m2 us loc mod_and_grp env warns
+ = case splitUniqSupply us of { (s1, s2) ->
+ case (m1 s1 loc mod_and_grp env warns) of { (result1, warns1) ->
+ case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
(combiner result1 result2, warns2) }}}
returnDs :: a -> DsM a
-returnDs result us loc sw_chkr mod_and_grp env warns = (result, warns)
+returnDs result us loc mod_and_grp env warns = (result, warns)
listDs :: [DsM a] -> DsM [a]
listDs [] = returnDs []
= f x y `thenDs` \ r ->
zipWithDs f xs ys `thenDs` \ rs ->
returnDs (r:rs)
+-- Note: crashes if lists not equal length (like zipWithEqual)
\end{code}
And all this mysterious stuff is so we can occasionally reach out and
functions are defined with it. The difference in name-strings makes
it easier to read debugging output.
\begin{code}
-newLocalDs :: FAST_STRING -> UniType -> DsM Id
-newLocalDs nm ty us loc sw_chkr mod_and_grp env warns
- = case (getSUnique us) of { assigned_uniq ->
+newLocalDs :: FAST_STRING -> Type -> DsM Id
+newLocalDs nm ty us loc mod_and_grp env warns
+ = case (getUnique us) of { assigned_uniq ->
(mkSysLocal nm assigned_uniq ty loc, warns) }
newSysLocalDs = newLocalDs SLIT("ds")
newFailLocalDs = newLocalDs SLIT("fail")
duplicateLocalDs :: Id -> DsM Id
-duplicateLocalDs old_local us loc sw_chkr mod_and_grp env warns
- = case (getSUnique us) of { assigned_uniq ->
+duplicateLocalDs old_local us loc mod_and_grp env warns
+ = case (getUnique us) of { assigned_uniq ->
(mkIdWithNewUniq old_local assigned_uniq, warns) }
cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
-cloneTyVarsDs tyvars us loc sw_chkr mod_and_grp env warns
- = case (getSUniques (length tyvars) us) of { uniqs ->
- (zipWith cloneTyVar tyvars uniqs, warns) }
+cloneTyVarsDs tyvars us loc mod_and_grp env warns
+ = case (getUniques (length tyvars) us) of { uniqs ->
+ (zipWithEqual cloneTyVar tyvars uniqs, warns) }
\end{code}
\begin{code}
-newTyVarsDs :: [TyVarTemplate] -> DsM [TyVar]
+newTyVarsDs :: [TyVar] -> DsM [TyVar]
-newTyVarsDs tyvar_tmpls us loc sw_chkr mod_and_grp env warns
- = case (getSUniques (length tyvar_tmpls) us) of { uniqs ->
- (zipWith cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) }
+newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
+ = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
+ (zipWithEqual cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) }
\end{code}
We can also reach out and either set/grab location information from
\begin{code}
uniqSMtoDsM :: UniqSM a -> DsM a
-uniqSMtoDsM u_action us loc sw_chkr mod_and_grp env warns
- = let
- us_to_use = mkUniqueSupplyGrimily us
- in
- (snd (u_action us_to_use), warns)
+uniqSMtoDsM u_action us loc mod_and_grp env warns
+ = (u_action us, warns)
getSrcLocDs :: DsM (String, String)
-getSrcLocDs us loc sw_chkr mod_and_grp env warns
+getSrcLocDs us loc mod_and_grp env warns
= case (unpackSrcLoc loc) of { (x,y) ->
((_UNPK_ x, _UNPK_ y), warns) }
putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc expr us old_loc sw_chkr mod_and_grp env warns
- = expr us new_loc sw_chkr mod_and_grp env warns
+putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
+ = expr us new_loc mod_and_grp env warns
dsShadowError :: DsMatchContext -> DsM ()
-dsShadowError cxt us loc sw_chkr mod_and_grp env warns
+dsShadowError cxt us loc mod_and_grp env warns
= ((), warns `snocBag` cxt)
\end{code}
\begin{code}
-getSwitchCheckerDs :: DsM (GlobalSwitch -> Bool)
-getSwitchCheckerDs us loc sw_chkr mod_and_grp env warns
- = (switchIsOn sw_chkr, warns)
-
-ifSwitchSetDs :: GlobalSwitch -> DsM a -> DsM a -> DsM a
-ifSwitchSetDs switch then_ else_ us loc sw_chkr mod_and_grp env warns
- = (if switchIsOn sw_chkr switch then then_ else else_)
- us loc sw_chkr mod_and_grp env warns
-
getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
-getModuleAndGroupDs us loc sw_chkr mod_and_grp env warns
+getModuleAndGroupDs us loc mod_and_grp env warns
= (mod_and_grp, warns)
\end{code}
\begin{code}
-type DsIdEnv = IdEnv PlainCoreExpr
+type DsIdEnv = IdEnv CoreExpr
-extendEnvDs :: [(Id, PlainCoreExpr)] -> DsM a -> DsM a
+extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
-extendEnvDs pairs expr us loc sw_chkr mod_and_grp old_env warns
+extendEnvDs pairs then_do us loc mod_and_grp old_env warns
= case splitUniqSupply us of { (s1, s2) ->
- case (mapAccumL subst s1 pairs) of { (_, revised_pairs) ->
- expr s2 loc sw_chkr mod_and_grp (growIdEnvList old_env revised_pairs) warns
- }}
+ let
+ revised_pairs = subst_all pairs s1
+ in
+ then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
+ }
where
- subst us (v, expr)
- = case splitUniqSupply us of { (s1, s2) ->
- let
- us_to_use = mkUniqueSupplyGrimily s1
- in
- case (substCoreExpr us_to_use old_env nullTyVarEnv expr) of { (_, expr2) ->
- (s2, (v, expr2)) }}
-
-lookupEnvDs :: Id -> DsM (Maybe PlainCoreExpr)
-lookupEnvDs id us loc sw_chkr mod_and_grp env warns
+ subst_all pairs = mapUs subst pairs
+
+ subst (v, expr)
+ = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
+ returnUs (v, new_expr)
+
+lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
+lookupEnvDs id us loc mod_and_grp env warns
= (lookupIdEnv env id, warns)
-- Note: we don't assert anything about the Id
-- being looked up. There's not really anything
-- much to say about it. (WDP 94/06)
-lookupEnvWithDefaultDs :: Id -> PlainCoreExpr -> DsM PlainCoreExpr
-lookupEnvWithDefaultDs id deflt us loc sw_chkr mod_and_grp env warns
+lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
+lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
= (case (lookupIdEnv env id) of
Nothing -> deflt
Just xx -> xx,
+++ /dev/null
-%************************************************************************
-%* *
-\section[DsParZF]{Desugaring Parallel ZF expressisions}
-%* *
-%************************************************************************
-
-\begin{code}
-#include "HsVersions.h"
-module DsParZF where
-
-IMPORT_Trace -- ToDo: rm
-
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
-import AbsPrel ( mkFunTy , eRROR_ID , integerTy,
- fromDomainId , toDomainId)
-import DsExpr ( dsExpr )
-import DsUtils ( mkSelectorBinds , EquationInfo(..))
-import Match ( match )
-import FiniteMap -- WAS: Set
-import FreeVars
-import SrcLoc
-import BasicLit ( BasicLit(..) )
-import Util
-\end{code}
-
-The purpose of the module is to convert the abstract syntax representation
-of parallel ZF expressions into the core syntax representation. The two
-representations differ in that the core syntax only contains binders in
-drawn and index from generators.
-
-\begin{description}
-\item[The ``Idea''] For each pattern in a generator we apply the function
-$\lambda hole\ .\ {\cal D}[[{\tt (\\pat ->}\ hole {\tt )x}]]$ to
-{\em every} expression in an inner scope than that of the definition of
-the pattern; {\tt x} represents the binder in the generator after translation,
-${\cal D}[[exp]]$ represents the desugaring of the expression $exp$.
-
-\item[Optimising the ``Idea''] We catagorise each pattern into two types;
-simple patterns in which their are no binders, and complex patterns. We
-only apply simple patterns to the left handside of a ZF expressions, and
-complex patterns to expressions in which the intersection of the free
-variables of the expression, and the binders of the pattern is non-empty.
-\end{description}
-
-%************************************************************************
-%* *
-\subsection[dsParallelZF]{Interface to the outside world}
-%* *
-%************************************************************************
-
-\begin{code}
-dsParallelZF::TypecheckedExpr -> TypecheckedParQuals -> DsM PlainCoreExpr
-dsParallelZF expr quals
- = dsParQuals quals `thenDs` (\ (quals',hf) ->
- dsExpr expr `thenDs` ( \ expr' ->
- let_1_0 (typeOfCoreExpr expr') ( \ ty ->
- returnDs (CoZfExpr (applyHoleLhsExpr ty expr' hf) quals') )))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[dsZF_datatype]{DataType used to represent ``HoleFunction''}
-%* *
-%************************************************************************
-
-\begin{code}
-type HoleFunction = (UniType -> PlainCoreExpr -> PlainCoreExpr,
- [(PlainCoreExpr -> Bool,
- UniType -> PlainCoreExpr -> PlainCoreExpr)])
-\end{code}
-
-\begin{code}
-combine fn fn' = \t e -> fn t (fn' t e)
-\end{code}
-
-\begin{code}
-combineHoles:: HoleFunction -> HoleFunction -> HoleFunction
-combineHoles (lhs,rhs) (lhs',rhs')
- = (combine lhs lhs',rhs++rhs')
-\end{code}
-
-\begin{code}
-identityHole::HoleFunction
-identityHole = (\t e -> e,[])
-\end{code}
-
-\begin{code}
-applyHoleLhsExpr:: UniType
- -> PlainCoreExpr
- -> HoleFunction
- -> PlainCoreExpr
-applyHoleLhsExpr ty expr (lhs,rhs)
- = (combine lhs (foldr combine (\t e -> e) (map snd rhs))) ty expr
-\end{code}
-
-\begin{code}
-applyHoleRhsExpr ty expr (_,rhs)
- = (foldr combine (\t e -> e) [ y | (x,y) <- rhs, (x expr)]) ty expr
-\end{code}
-
-\begin{code}
-applyHoleFunction :: PlainCoreParQuals
- -> HoleFunction
- -> PlainCoreParQuals
-applyHoleFunction (CoAndQuals left right) hf
- = CoAndQuals (applyHoleFunction left hf) (applyHoleFunction right hf)
-
-applyHoleFunction (CoParFilter expr) hf
- = CoParFilter (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf)
-
-applyHoleFunction (CoDrawnGen pats pat expr) hf
- = CoDrawnGen pats pat (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf)
-
-applyHoleFunction (CoIndexGen exprs pat expr) hf
- = CoIndexGen (map (\x -> applyHoleRhsExpr (typeOfCoreExpr x) x hf) exprs)
- pat
- (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[dsParQuals]{Desugaring the qualifiers}
-%* *
-%************************************************************************
-
-\begin{code}
-dsParQuals::TypecheckedParQuals
- -> DsM (PlainCoreParQuals,HoleFunction)
-\end{code}
-
-\begin{code}
-dsParQuals (AndParQuals left right)
- = dsParQuals left `thenDs` (\ (left', hfleft) ->
- dsParQuals right `thenDs` (\ (right',hfright) ->
- returnDs (CoAndQuals left' (applyHoleFunction right' hfleft),
- combineHoles hfleft hfright) ))
-
-\end{code}
-
-\begin{code}
-dsParQuals (ParFilter expr)
- = dsExpr expr `thenDs` (\ expr' ->
- returnDs (CoParFilter expr', identityHole) )
-
-dsParQuals (DrawnGenOut pats convs pat dRHS)
- = listDs (map dsExpr convs) `thenDs` (\ convs' ->
- listDs (map prettyNewLocalDs pats)
- `thenDs` (\ binders ->
- listDs (zipWith3 dsPid pats binders convs')
- `thenDs` (\ hfList ->
- let_1_0 (foldr1 (combineHoles) hfList) (\ hf ->
- prettyNewLocalDs pat `thenDs` (\ iden ->
- duplicateLocalDs iden `thenDs` (\ binder ->
- dsPid pat binder (CoLam [iden] (CoVar iden))
- `thenDs` (\ hf' ->
- dsExpr dRHS `thenDs` (\ dRHS' ->
- returnDs (CoDrawnGen binders binder dRHS',
- combineHoles hf hf') ))))))))
-
-
-dsParQuals (IndexGen exprs pat iRHS)
- = listDs (map dsExpr exprs) `thenDs` (\ exprs' ->
- prettyNewLocalDs pat `thenDs` (\ binder ->
- duplicateLocalDs binder `thenDs` (\ iden ->
- dsPid pat binder (CoLam [iden] (CoVar iden))
- `thenDs` (\ hf ->
- dsExpr iRHS `thenDs` (\ iRHS' ->
- returnDs (CoIndexGen exprs' binder iRHS' ,hf) )))))
-
-\end{code}
-
-\begin{code}
-dsPid:: TypecheckedPat -- Pattern to be desugared
- -> Id -- Patterns desugared binder
- -> PlainCoreExpr -- Conversion function
- -> DsM HoleFunction
-
-dsPid pat binder conv
- = duplicateLocalDs binder `thenDs` (\ lambdaBind ->
- getSrcLocDs `thenDs` (\ (sfile,sline) ->
- let_1_0 ("\""++sfile++"\", line "++sline++" : "++
- "Processor not defined\n") ( \ errorStr ->
- getUniqueSupplyDs `thenDs` (\ us ->
- let_1_0 (collectTypedPatBinders pat) (\ patBinders ->
- case (null patBinders) of
- True -> returnDs (mkHole lambdaBind errorStr us,[])
- False ->
- returnDs (\t e -> e, [(mkPredicate patBinders,
- mkHole lambdaBind errorStr us)]) )))))
-
- where
- mkPredicate b e
- = let_1_0 (freeStuff b e) (\ ((fvSet,_),_) ->
- let_1_0 (mkSet b) (\ bSet ->
- not (isEmptySet (intersect fvSet bSet)) ))
-
- mkHole lambdaBind errorStr us
- = \ ty expr ->
- (CoApp
- (CoLam
- [lambdaBind]
- (snd (initDs
- us
- nullIdEnv
- (\ _ -> False) -- Hack alert!!!
- (panic "mkHole: module name")
- (match [lambdaBind] [([pat], \x -> expr)]
- (CoApp
- (mkCoTyApp (CoVar eRROR_ID) ty)
- (CoLit (NoRepStr (_PK_ errorStr))))))))
- (CoApp conv (CoVar binder)))
-\end{code}
-
-In the mkHole function we need to conjure up some state so we can
-use the match function...
-%************************************************************************
-%* *
-\subsection[prettyLocals]{Make a new binder; try and keep names nice :-)}
-%* *
-%************************************************************************
-
-\begin{code}
-prettyNewLocalDs::TypecheckedPat -> DsM Id
-prettyNewLocalDs (VarPat id) = duplicateLocalDs id
-prettyNewLocalDs (AsPat id _) = duplicateLocalDs id
-preetyNewLocalDs pat = let_1_0 (typeOfPat pat) (\ pat_ty->
- newSysLocalDs pat_ty
- )
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface DsUtils where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreAtom, CoreBinding, CoreExpr)
-import DsMonad(DsMatchContext)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data CanItFail = CanFail | CantFail
-data EquationInfo = EqnInfo [TypecheckedPat] MatchResult
-data MatchResult = MatchResult CanItFail UniType (CoreExpr Id Id -> CoreExpr Id Id) DsMatchContext
-combineGRHSMatchResults :: MatchResult -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-combineMatchResults :: MatchResult -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-dsExprToAtom :: CoreExpr Id Id -> (CoreAtom Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-mkCoAlgCaseMatchResult :: Id -> [(Id, [Id], MatchResult)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-mkCoAppDs :: CoreExpr Id Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-mkCoConDs :: Id -> [UniType] -> [CoreExpr Id Id] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-mkCoLetsMatchResult :: [CoreBinding Id Id] -> MatchResult -> MatchResult
-mkCoPrimCaseMatchResult :: Id -> [(BasicLit, MatchResult)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-mkCoPrimDs :: PrimOp -> [UniType] -> [CoreExpr Id Id] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-mkFailurePair :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((CoreExpr Id Id -> CoreBinding Id Id, CoreExpr Id Id), Bag DsMatchContext)
-mkGuardedMatchResult :: CoreExpr Id Id -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-mkSelectorBinds :: [TyVar] -> TypecheckedPat -> [(Id, Id)] -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([(Id, CoreExpr Id Id)], Bag DsMatchContext)
-mkTupleBind :: [TyVar] -> [Id] -> [(Id, Id)] -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([(Id, CoreExpr Id Id)], Bag DsMatchContext)
-mkTupleExpr :: [Id] -> CoreExpr Id Id
-selectMatchVars :: [TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([Id], Bag DsMatchContext)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DsUtils]{Utilities for desugaring}
combineMatchResults,
dsExprToAtom,
mkCoAlgCaseMatchResult,
- mkCoAppDs,
- mkCoConDs,
+ mkAppDs, mkConDs, mkPrimDs,
mkCoLetsMatchResult,
mkCoPrimCaseMatchResult,
- mkCoPrimDs,
mkFailurePair,
mkGuardedMatchResult,
mkSelectorBinds,
selectMatchVars
) where
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
-
-import AbsPrel ( mkFunTy, stringTy
- IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
- )
-import AbsUniType ( mkTyVarTy, quantifyTy, mkTupleTyCon,
- mkRhoTy, splitDictType, applyTyCon,
- getUniDataTyCon, isUnboxedDataType,
- TyVar, TyVarTemplate, TyCon, Arity(..), Class,
- UniType, RhoType(..), SigmaType(..)
- )
-import Id ( getIdUniType, getInstantiatedDataConSig,
- mkTupleCon, DataCon(..), Id
- )
-import Maybes ( Maybe(..) )
-import Match ( match, matchSimply )
-import Pretty
-import Unique ( initUs, UniqueSupply, UniqSM(..) )
-import UniqSet
-import Util
+import Ubiq
+import DsLoop ( match, matchSimply )
+
+import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
+ Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
+import TcHsSyn ( TypecheckedPat(..) )
+import DsHsSyn ( outPatType )
+import CoreSyn
+
+import DsMonad
+
+import CoreUtils ( coreExprType, escErrorMsg, mkCoreIfThenElse, mkErrorApp )
+import PrelInfo ( stringTy )
+import Id ( idType, getInstantiatedDataConSig, mkTupleCon,
+ DataCon(..), DictVar(..), Id(..), GenId )
+import TyCon ( mkTupleTyCon )
+import Type ( mkTyVarTy, mkRhoTy, mkFunTys,
+ applyTyCon, getAppDataTyCon )
+import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
+import Util ( panic, assertPanic )
+
+isUnboxedDataType = panic "DsUtils.isUnboxedDataType"
+quantifyTy = panic "DsUtils.quantifyTy"
+splitDictType = panic "DsUtils.splitDictType"
+mkCoTyApps = panic "DsUtils.mkCoTyApps"
\end{code}
%************************************************************************
worthy of a type synonym and a few handy functions.
\begin{code}
-data EquationInfo
+data EquationInfo
= EqnInfo
[TypecheckedPat] -- the patterns for an eqn
MatchResult -- Encapsulates the guards and bindings
data MatchResult
= MatchResult
CanItFail
- UniType -- Type of argument expression
+ Type -- Type of argument expression
- (PlainCoreExpr -> PlainCoreExpr)
+ (CoreExpr -> CoreExpr)
-- Takes a expression to plug in at the
-- failure point(s). The expression should
-- be duplicatable!
orFail _ _ = CanFail
-mkCoLetsMatchResult :: [PlainCoreBinding] -> MatchResult -> MatchResult
-mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
+mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult
+mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt)
= MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt
-mkGuardedMatchResult :: PlainCoreExpr -> MatchResult -> DsM MatchResult
+mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult
mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
= returnDs (MatchResult CanFail
ty
)
mkCoPrimCaseMatchResult :: Id -- Scrutinee
- -> [(BasicLit, MatchResult)] -- Alternatives
+ -> [(Literal, MatchResult)] -- Alternatives
-> DsM MatchResult
mkCoPrimCaseMatchResult var alts
- = newSysLocalDs (getIdUniType var) `thenDs` \ wild ->
+ = newSysLocalDs (idType var) `thenDs` \ wild ->
returnDs (MatchResult CanFail
ty1
(mk_case alts wild)
((_,MatchResult _ ty1 _ cxt1) : _) = alts
mk_case alts wild fail_expr
- = CoCase (CoVar var) (CoPrimAlts final_alts (CoBindDefault wild fail_expr))
+ = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
where
- final_alts = [ (lit, body_fn fail_expr)
+ final_alts = [ (lit, body_fn fail_expr)
| (lit, MatchResult _ _ body_fn _) <- alts
]
mkCoAlgCaseMatchResult :: Id -- Scrutinee
- -> [(DataCon, [Id], MatchResult)] -- Alternatives
+ -> [(DataCon, [Id], MatchResult)] -- Alternatives
-> DsM MatchResult
mkCoAlgCaseMatchResult var alts
= -- Find all the constructors in the type which aren't
-- explicitly mentioned in the alternatives:
case un_mentioned_constructors of
[] -> -- All constructors mentioned, so no default needed
- returnDs (MatchResult can_any_alt_fail
- ty1
- (mk_case alts (\ignore -> CoNoDefault))
+ returnDs (MatchResult can_any_alt_fail
+ ty1
+ (mk_case alts (\ignore -> NoDefault))
cxt1)
[con] -> -- Just one constructor missing, so add a case for it
- -- We need to build new locals for the args of the constructor,
+ -- We need to build new locals for the args of the constructor,
-- and figuring out their types is somewhat tiresome.
let
(_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys
in
newSysLocalsDs arg_tys `thenDs` \ arg_ids ->
-
+
-- Now we are ready to construct the new alternative
let
new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext)
in
returnDs (MatchResult CanFail
- ty1
- (mk_case (new_alt:alts) (\ignore -> CoNoDefault))
+ ty1
+ (mk_case (new_alt:alts) (\ignore -> NoDefault))
cxt1)
other -> -- Many constructors missing, so use a default case
newSysLocalDs scrut_ty `thenDs` \ wild ->
returnDs (MatchResult CanFail
- ty1
- (mk_case alts (\fail_expr -> CoBindDefault wild fail_expr))
+ ty1
+ (mk_case alts (\fail_expr -> BindDefault wild fail_expr))
cxt1)
where
- scrut_ty = getIdUniType var
- (tycon, tycon_arg_tys, data_cons) = getUniDataTyCon scrut_ty
+ scrut_ty = idType var
+ (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty
un_mentioned_constructors
= uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
mk_case alts deflt_fn fail_expr
- = CoCase (CoVar var) (CoAlgAlts final_alts (deflt_fn fail_expr))
+ = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
where
- final_alts = [ (con, args, body_fn fail_expr)
+ final_alts = [ (con, args, body_fn fail_expr)
| (con, args, MatchResult _ _ body_fn _) <- alts
]
combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
- (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
+ (MatchResult can_it_fail2 ty2 body_fn2 cxt2)
= mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
let
- new_body_fn1 = \body1 -> CoLet (bind_fn body1) (body_fn1 duplicatable_expr)
+ new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
in
returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1)
-combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
+combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1)
match_result2
= returnDs match_result1
-- need to let-bind to avoid code duplication
combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1)
- (MatchResult can_it_fail ty2 body_fn2 cxt2)
+ (MatchResult can_it_fail ty2 body_fn2 cxt2)
= returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
combineGRHSMatchResults match_result1 match_result2
%************************************************************************
\begin{code}
-dsExprToAtom :: PlainCoreExpr -- The argument expression
- -> (PlainCoreAtom -> DsM PlainCoreExpr) -- Something taking the argument *atom*,
- -- and delivering an expression E
- -> DsM PlainCoreExpr -- Either E or let x=arg-expr in E
+dsExprToAtom :: CoreExpr -- The argument expression
+ -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
+ -- and delivering an expression E
+ -> DsM CoreExpr -- Either E or let x=arg-expr in E
-dsExprToAtom (CoVar v) continue_with = continue_with (CoVarAtom v)
-dsExprToAtom (CoLit v) continue_with = continue_with (CoLitAtom v)
+dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
+dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
dsExprToAtom arg_expr continue_with
- = newSysLocalDs ty `thenDs` \ arg_id ->
- continue_with (CoVarAtom arg_id) `thenDs` \ body ->
- if isUnboxedDataType ty
- then returnDs (CoCase arg_expr (CoPrimAlts [] (CoBindDefault arg_id body)))
- else returnDs (CoLet (CoNonRec arg_id arg_expr) body)
- where
- ty = typeOfCoreExpr arg_expr
+ = let
+ ty = coreExprType arg_expr
+ in
+ newSysLocalDs ty `thenDs` \ arg_id ->
+ continue_with (VarArg arg_id) `thenDs` \ body ->
+ returnDs (
+ if isUnboxedDataType ty
+ then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
+ else Let (NonRec arg_id arg_expr) body
+ )
-dsExprsToAtoms :: [PlainCoreExpr]
- -> ([PlainCoreAtom] -> DsM PlainCoreExpr)
- -> DsM PlainCoreExpr
+dsExprsToAtoms :: [CoreExpr]
+ -> ([CoreArg] -> DsM CoreExpr)
+ -> DsM CoreExpr
dsExprsToAtoms [] continue_with
= continue_with []
dsExprsToAtoms (arg:args) continue_with
- = dsExprToAtom arg (\ arg_atom ->
- dsExprsToAtoms args (\ arg_atoms ->
+ = dsExprToAtom arg $ \ arg_atom ->
+ dsExprsToAtoms args $ \ arg_atoms ->
continue_with (arg_atom:arg_atoms)
- ))
\end{code}
%************************************************************************
%* *
-\subsection[mkCoAppDs]{Desugarer's versions of some Core functions}
+\subsection{Desugarer's versions of some Core functions}
%* *
%************************************************************************
-Plumb the desugarer's @UniqueSupply@ in/out of the @UniqueSupplyMonad@
+Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad
world.
\begin{code}
-mkCoAppDs :: PlainCoreExpr -> PlainCoreExpr -> DsM PlainCoreExpr
-mkCoConDs :: Id -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr
-mkCoPrimDs :: PrimOp -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr
+mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
+mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr
+mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr
-mkCoAppDs fun arg_expr
- = dsExprToAtom arg_expr (\ arg_atom -> returnDs (CoApp fun arg_atom))
+mkAppDs fun tys arg_exprs
+ = dsExprsToAtoms arg_exprs $ \ vals ->
+ returnDs (mkApp fun [] tys vals)
-mkCoConDs con tys arg_exprs
- = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoCon con tys arg_atoms))
+mkConDs con tys arg_exprs
+ = dsExprsToAtoms arg_exprs $ \ vals ->
+ returnDs (mkCon con [] tys vals)
-mkCoPrimDs op tys arg_exprs
- = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoPrim op tys arg_atoms))
+mkPrimDs op tys arg_exprs
+ = dsExprsToAtoms arg_exprs $ \ vals ->
+ returnDs (mkPrim op [] tys vals)
\end{code}
%************************************************************************
-> TypecheckedPat -- The pattern
-> [(Id,Id)] -- Monomorphic and polymorphic binders for
-- the pattern
- -> PlainCoreExpr -- Expression to which the pattern is bound
- -> DsM [(Id,PlainCoreExpr)]
+ -> CoreExpr -- Expression to which the pattern is bound
+ -> DsM [(Id,CoreExpr)]
mkSelectorBinds tyvars pat locals_and_globals val_expr
= getSrcLocDs `thenDs` \ (src_file, src_line) ->
let
src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
error_string = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern"
- error_msg = mkErrorCoApp res_ty str_var error_string
+ error_msg = mkErrorApp res_ty str_var error_string
in
matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
mkTupleBind tyvars [] locals_and_globals tuple_expr
where
locals = [local | (local, _) <- locals_and_globals]
local_tuple = mkTupleExpr locals
- res_ty = typeOfCoreExpr local_tuple
+ res_ty = coreExprType local_tuple
is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
is_simple_tuple_pat other = False
We're about to match against some patterns. We want to make some
@Ids@ to use as match variables. If a pattern has an @Id@ readily at
-hand, which should indeed be bound to the pattern as a whole, then use it;
+hand, which should indeed be bound to the pattern as a whole, then use it;
otherwise, make one up.
\begin{code}
selectMatchVars :: [TypecheckedPat] -> DsM [Id]
var_from_pat_maybe (VarPat var) = returnDs var
var_from_pat_maybe (AsPat var pat) = returnDs var
var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat
-
--- var_from_pat_maybe (NPlusKPat n _ _ _ _ _) = returnDs n
--- WRONG! We don't want to bind n to the pattern as a whole!
-
var_from_pat_maybe other_pat
- = newSysLocalDs (typeOfPat other_pat) -- OK, better make up one...
+ = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
\end{code}
\begin{code}
mkTupleBind :: [TyVar] -- Abstract wrt these...
-> [DictVar] -- ... and these
-
+
-> [(Id, Id)] -- Local, global pairs, equal in number
-- to the size of the tuple. The types
-- of the globals is the generalisation of
-- the corresp local, wrt the tyvars and dicts
-
- -> PlainCoreExpr -- Expr whose value is a tuple; the expression
+
+ -> CoreExpr -- Expr whose value is a tuple; the expression
-- may mention the tyvars and dicts
-
- -> DsM [(Id, PlainCoreExpr)] -- Bindings for the globals
+
+ -> DsM [(Id, CoreExpr)] -- Bindings for the globals
\end{code}
The general call is
\begin{code}
mkTupleBind tyvars dicts [(local,global)] tuple_expr
- = returnDs [(global, mkCoTyLam tyvars (mkCoLam dicts tuple_expr))]
+ = returnDs [(global, mkLam tyvars dicts tuple_expr)]
\end{code}
The general case:
mkTupleBind tyvars dicts local_global_prs tuple_expr
= newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
- zipWithDs (mk_selector (CoVar tuple_var))
+ zipWithDs (mk_selector (Var tuple_var))
local_global_prs
[(0::Int) .. (length local_global_prs - 1)]
`thenDs` \ tup_selectors ->
returnDs (
- (tuple_var, mkCoTyLam tyvars (mkCoLam dicts tuple_expr)) :
- tup_selectors
+ (tuple_var, mkLam tyvars dicts tuple_expr)
+ : tup_selectors
)
where
locals, globals :: [Id]
no_of_binders = length local_global_prs
tyvar_tys = map mkTyVarTy tyvars
- tuple_var_ty :: UniType
+ tuple_var_ty :: Type
tuple_var_ty
= case (quantifyTy tyvars (mkRhoTy theta
- (applyTyCon (mkTupleTyCon no_of_binders)
- (map getIdUniType locals)))) of
+ (applyTyCon (mkTupleTyCon no_of_binders)
+ (map idType locals)))) of
(_{-tossed templates-}, ty) -> ty
where
- theta = map (splitDictType . getIdUniType) dicts
+ theta = map (splitDictType . idType) dicts
- mk_selector :: PlainCoreExpr -> (Id, Id) -> Int -> DsM (Id, PlainCoreExpr)
+ mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr)
mk_selector tuple_var_expr (local, global) which_local
= mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders ->
selected = binders !! which_local
in
returnDs (
- (global, mkCoTyLam tyvars (
- mkCoLam dicts (
- mkTupleSelector (mkCoApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
- binders selected)))
+ global,
+ mkLam tyvars dicts (
+ mkTupleSelector (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
+ binders selected)
)
-mkCoApp_XX :: PlainCoreExpr -> [Id] -> PlainCoreExpr
-mkCoApp_XX expr [] = expr
-mkCoApp_XX expr (id:ids) = mkCoApp_XX (CoApp expr (CoVarAtom id)) ids
+mkApp_XX :: CoreExpr -> [Id] -> CoreExpr
+mkApp_XX expr [] = expr
+mkApp_XX expr (id:ids) = mkApp_XX (App expr (VarArg id)) ids
\end{code}
-@mkTupleExpr@ builds a tuple; the inverse to mkTupleSelector.
-If it has only one element, it is
-the identity function.
-
+@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
+has only one element, it is the identity function.
\begin{code}
-mkTupleExpr :: [Id] -> PlainCoreExpr
-
-mkTupleExpr [] = CoCon (mkTupleCon 0) [] []
-mkTupleExpr [id] = CoVar id
-mkTupleExpr ids = CoCon (mkTupleCon (length ids))
- (map getIdUniType ids)
- [ CoVarAtom i | i <- ids ]
+mkTupleExpr :: [Id] -> CoreExpr
+
+mkTupleExpr [] = Con (mkTupleCon 0) []
+mkTupleExpr [id] = Var id
+mkTupleExpr ids = mkCon (mkTupleCon (length ids))
+ [{-usages-}]
+ (map idType ids)
+ [ VarArg i | i <- ids ]
\end{code}
@mkTupleSelector@ builds a selector which scrutises the given
expression and extracts the one name from the list given.
-If you want the no-shadowing rule to apply, the caller
+If you want the no-shadowing rule to apply, the caller
is responsible for making sure that none of these names
are in scope.
just the identity.
\begin{code}
-mkTupleSelector :: PlainCoreExpr -- Scrutinee
+mkTupleSelector :: CoreExpr -- Scrutinee
-> [Id] -- The tuple args
-> Id -- The selected one
- -> PlainCoreExpr
+ -> CoreExpr
mkTupleSelector expr [] the_var = panic "mkTupleSelector"
= ASSERT(var == should_be_the_same_var)
expr
-mkTupleSelector expr vars the_var
- = CoCase expr (CoAlgAlts [(mkTupleCon arity, vars, CoVar the_var)]
- CoNoDefault)
+mkTupleSelector expr vars the_var
+ = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
+ NoDefault)
where
arity = length vars
\end{code}
\end{verbatim}
which is of course utterly wrong. Rather than drop the condition that
-only boxed types can be let-bound, we just turn the fail into a function
+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#
Now fail.33 is a function, so it can be let-bound.
\begin{code}
-mkFailurePair :: UniType -- Result type of the whole case expression
- -> DsM (PlainCoreExpr -> PlainCoreBinding,
- -- Binds the newly-created fail variable
- -- to either the expression or \_ -> expression
- PlainCoreExpr) -- Either the fail variable, or fail variable
- -- applied to unit tuple
+mkFailurePair :: Type -- Result type of the whole case expression
+ -> DsM (CoreExpr -> CoreBinding,
+ -- Binds the newly-created fail variable
+ -- to either the expression or \ _ -> expression
+ CoreExpr) -- Either the fail variable, or fail variable
+ -- applied to unit tuple
mkFailurePair ty
| isUnboxedDataType ty
- = newFailLocalDs (mkFunTy unit_ty ty) `thenDs` \ fail_fun_var ->
- newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
- returnDs (\ body -> CoNonRec fail_fun_var (CoLam [fail_fun_arg] body),
- CoApp (CoVar fail_fun_var) (CoVarAtom unit_id))
+ = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
+ newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
+ returnDs (\ body ->
+ NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
+ App (Var fail_fun_var) (VarArg unit_id))
| otherwise
= newFailLocalDs ty `thenDs` \ fail_var ->
- returnDs (\ body -> CoNonRec fail_var body, CoVar fail_var)
+ returnDs (\ body -> NonRec fail_var body, Var fail_var)
unit_id :: Id -- out here to avoid CAF (sigh)
unit_id = mkTupleCon 0
-unit_ty :: UniType
-unit_ty = getIdUniType unit_id
+unit_ty :: Type
+unit_ty = idType unit_id
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Match where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext, DsMatchKind)
-import DsUtils(EquationInfo, MatchResult)
-import HsMatches(Match)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniType(UniType)
-import UniqFM(UniqFM)
-match :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-matchSimply :: CoreExpr Id Id -> TypecheckedPat -> UniType -> CoreExpr Id Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
-matchWrapper :: DsMatchKind -> [Match Id TypecheckedPat] -> [Char] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([Id], CoreExpr Id Id), Bag DsMatchContext)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Main_match]{The @match@ function}
\begin{code}
-module Match (
- match, matchWrapper, matchSimply
- ) where
-
#include "HsVersions.h"
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
+module Match ( match, matchWrapper, matchSimply ) where
-import AbsPrel ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
- charTy, charDataCon, intTy, intDataCon, floatTy,
- floatDataCon, doubleTy, doubleDataCon,
- integerTy, intPrimTy, charPrimTy,
- floatPrimTy, doublePrimTy, mkFunTy, stringTy,
- addrTy, addrPrimTy, addrDataCon,
- wordTy, wordPrimTy, wordDataCon
-#ifdef DPH
- ,mkProcessorTy
-#endif {- Data Parallel Haskell -}
- )
-import PrimKind ( PrimKind(..) ) -- Rather ugly import; ToDo???
-
-import AbsUniType ( isPrimType )
-import DsBinds ( dsBinds )
-import DsExpr ( dsExpr )
+import Ubiq
+import DsLoop -- here for paranoia-checking reasons
+ -- and to break dsExpr/dsBinds-ish loop
+
+import HsSyn
+import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..),
+ TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
+import DsHsSyn ( outPatType, collectTypedPatBinders )
+import CoreSyn
+
+import DsMonad
import DsGRHSs ( dsGRHSs )
import DsUtils
-#ifdef DPH
-import Id ( eqId, getIdUniType, mkTupleCon, mkProcessorCon )
-import MatchProc ( matchProcessor)
-#else
-import Id ( eqId, getIdUniType, mkTupleCon, DataCon(..), Id )
-#endif {- Data Parallel Haskell -}
-import Maybes ( Maybe(..) )
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
-import Outputable -- all for one "panic"...
-import Pretty
-import Util
+
+import CoreUtils ( escErrorMsg, mkErrorApp )
+import Id ( idType, mkTupleCon, GenId{-instance-} )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenTyVar{-instance-}, GenType{-instance-} )
+import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+ charTy, charDataCon, intTy, intDataCon,
+ floatTy, floatDataCon, doubleTy, doubleDataCon,
+ integerTy, intPrimTy, charPrimTy,
+ floatPrimTy, doublePrimTy, stringTy,
+ addrTy, addrPrimTy, addrDataCon,
+ wordTy, wordPrimTy, wordDataCon )
+import Type ( isPrimType, eqTy )
+import TyVar ( GenTyVar )
+import Unique ( Unique )
+import Util ( panic, pprPanic )
\end{code}
The function @match@ is basically the same as in the Wadler chapter,
\item
the $n$ patterns for that equation, and
\item
-a list of Core bindings [@(Id, PlainCoreExpr)@ pairs] to be ``stuck on
+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
the front'' of the matching code, as in:
\begin{verbatim}
let <binds>
\item
A default expression---what to evaluate if the overall pattern-match
fails. This expression will (almost?) always be
-a measly expression @CoVar@, unless we know it will only be used once
+a measly expression @Var@, unless we know it will only be used once
(as we do in @glue_success_exprs@).
Leaving out this third argument to @match@ (and slamming in lots of
-@CoVar "fail"@s) is a positively {\em bad} idea, because it makes it
+@Var "fail"@s) is a positively {\em bad} idea, because it makes it
impossible to share the default expressions. (Also, it stands no
chance of working in our post-upheaval world of @Locals@.)
\end{enumerate}
returnDs match_result
else
returnDs match_result
-
+
where
pin_eqns [EqnInfo [] match_result] = returnDs match_result
-- Last eqn... can't have pats ...
pin_eqns (EqnInfo [] match_result1 : more_eqns)
= pin_eqns more_eqns `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
+ combineMatchResults match_result1 match_result2
pin_eqns other_pat = panic "match: pin_eqns"
match vars@(v:vs) eqns_info shadows
= mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
mapDs (tidyEqnInfo v) shadows `thenDs` \ tidy_shadows ->
- let
+ let
tidy_eqns_blks = unmix_eqns tidy_eqns_info
in
match_unmixed_eqn_blks vars tidy_eqns_blks tidy_shadows
\item[@ConPats@:]
@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
-\item[@LitPats@ and @NPats@ (and @NPlusKPats@):]
-@LitPats@/@NPats@/@NPlusKPats@ of ``known friendly types'' (Int, Char,
+\item[@LitPats@ and @NPats@:]
+@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
Float, Double, at least) are converted to unboxed form; e.g.,
-\tr{(NPat (IntLit i) _ _)} is converted to:
+\tr{(NPat (HsInt i) _ _)} is converted to:
\begin{verbatim}
-(ConPat I# _ _ [LitPat (IntPrimLit i) _])
+(ConPat I# _ _ [LitPat (HsIntPrim i) _])
\end{verbatim}
\end{description}
-- of new bindings to be added to the front
tidy1 v (VarPat var) match_result
- = returnDs (WildPat (getIdUniType var),
+ = returnDs (WildPat (idType var),
mkCoLetsMatchResult extra_binds match_result)
where
- extra_binds | v `eqId` var = []
- | otherwise = [CoNonRec var (CoVar v)]
+ extra_binds | v == var = []
+ | otherwise = [NonRec var (Var v)]
tidy1 v (AsPat var pat) match_result
= tidy1 v pat (mkCoLetsMatchResult extra_binds match_result)
where
- extra_binds | v `eqId` var = []
- | otherwise = [CoNonRec var (CoVar v)]
+ extra_binds | v == var = []
+ | otherwise = [NonRec var (Var v)]
tidy1 v (WildPat ty) match_result
= returnDs (WildPat ty, match_result)
ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
- The case expr for v_i is just: match [v] [(p, [], \ x -> CoVar v_i)] any_expr
+ The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
-}
tidy1 v (LazyPat pat) match_result
- = mkSelectorBinds [] pat l_to_l (CoVar v) `thenDs` \ sel_binds ->
- returnDs (WildPat (getIdUniType v),
- mkCoLetsMatchResult [CoNonRec b rhs | (b,rhs) <- sel_binds] match_result)
+ = mkSelectorBinds [] pat l_to_l (Var v) `thenDs` \ sel_binds ->
+ returnDs (WildPat (idType v),
+ mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
where
l_to_l = binders `zip` binders -- Boring
binders = collectTypedPatBinders pat
arity = length pats
tuple_ConPat
= ConPat (mkTupleCon arity)
- (mkTupleTy arity (map typeOfPat pats))
+ (mkTupleTy arity (map outPatType pats))
pats
-#ifdef DPH
-tidy1 v (ProcessorPat pats convs pat) match_result
- = returnDs ((ProcessorPat pats convs pat), match_result)
-{-
-tidy1 v (ProcessorPat pats _ _ pat) match_result
- = returnDs (processor_ConPat, match_result)
+tidy1 v (DictPat dicts methods) match_result
+ = case num_of_d_and_ms of
+ 0 -> tidy1 v (TuplePat []) match_result
+ 1 -> tidy1 v (head dict_and_method_pats) match_result
+ _ -> tidy1 v (TuplePat dict_and_method_pats) match_result
where
- processor_ConPat
- = ConPat (mkProcessorCon (length pats))
- (mkProcessorTy (map typeOfPat pats) (typeOfPat pat))
- (pats++[pat])
--}
-#endif {- Data Parallel Haskell -}
+ num_of_d_and_ms = length dicts + length methods
+ dict_and_method_pats = map VarPat (dicts ++ methods)
+
-- deeply ugly mangling for some (common) NPats/LitPats
| isPrimType lit_ty
= returnDs (pat, match_result)
- | lit_ty == charTy
+ | lit_ty `eqTy` charTy
= returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
match_result)
| otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
where
- mk_char (CharLit c) = CharPrimLit c
+ mk_char (HsChar c) = HsCharPrim c
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 v pat@(NPat lit lit_ty _) match_result
= returnDs (better_pat, match_result)
where
- better_pat
- | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
- | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
- | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
- | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
- | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
- | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
+ better_pat
+ | lit_ty `eqTy` charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy]
+ | lit_ty `eqTy` intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy]
+ | lit_ty `eqTy` wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy]
+ | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy]
+ | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy]
+ | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
| otherwise = pat
- mk_int (IntLit i) = IntPrimLit i
- mk_int l@(LitLitLit s _) = l
-
- mk_char (CharLit c)= CharPrimLit c
- mk_char l@(LitLitLit s _) = l
-
- mk_word l@(LitLitLit s _) = l
-
- mk_addr l@(LitLitLit s _) = l
-
- mk_float (IntLit i) = FloatPrimLit (fromInteger i)
-#if __GLASGOW_HASKELL__ <= 22
- mk_float (FracLit f)= FloatPrimLit (fromRational f) -- ToDo???
-#else
- mk_float (FracLit f)= FloatPrimLit f
-#endif
- mk_float l@(LitLitLit s _) = l
-
- mk_double (IntLit i) = DoublePrimLit (fromInteger i)
-#if __GLASGOW_HASKELL__ <= 22
- mk_double (FracLit f)= DoublePrimLit (fromRational f) -- ToDo???
-#else
- mk_double (FracLit f)= DoublePrimLit f
-#endif
- mk_double l@(LitLitLit s _) = l
-
-{- OLD: and wrong! I don't think we can do anything
- useful with n+k patterns, so drop through to default case
-
-tidy1 v pat@(NPlusKPat n k lit_ty and so on) match_result
- = returnDs (NPlusKPat v k lit_ty and so on,
- (if v `eqId` n then id else (mkCoLet (CoNonRec n (CoVar v)))) . match_result)
--}
+ mk_int (HsInt i) = HsIntPrim i
+ mk_int l@(HsLitLit s) = l
+
+ mk_char (HsChar c) = HsCharPrim c
+ mk_char l@(HsLitLit s) = l
+
+ mk_word l@(HsLitLit s) = l
+
+ mk_addr l@(HsLitLit s) = l
+
+ mk_float (HsInt i) = HsFloatPrim (fromInteger i)
+ mk_float (HsFrac f) = HsFloatPrim f
+ mk_float l@(HsLitLit s) = l
+
+ mk_double (HsInt i) = HsDoublePrim (fromInteger i)
+ mk_double (HsFrac f) = HsDoublePrim f
+ mk_double l@(HsLitLit s) = l
-- and everything else goes through unchanged...
= -- Real true variables, just like in matchVar, SLPJ p 94
match vars remaining_eqns_info remaining_shadows
-#ifdef DPH
- | patsAreAllProcessor column_1_pats
- = -- ToDo: maybe check just one...
- matchProcessor all_vars eqns_info
-#endif {- Data Parallel Haskell -}
-
| patsAreAllCons column_1_pats -- ToDo: maybe check just one...
= matchConFamily all_vars eqns_info shadows
where
column_1_pats = [pat | EqnInfo (pat:_) _ <- eqns_info]
remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info]
- remaining_shadows = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows,
+ remaining_shadows = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows,
irrefutablePat pat ]
-- Discard shadows which can be refuted, since they don't shadow
-- a variable
A list of variables (@Locals@) that the caller must ``promise'' to
bind to appropriate values; and
\item
-a @PlainCoreExpr@, the desugared output (main result).
+a @CoreExpr@, the desugared output (main result).
\end{itemize}
The main actions of @matchWrapper@ include:
matchWrapper :: DsMatchKind -- For shadowing warning messages
-> [TypecheckedMatch] -- Matches being desugared
-> String -- Error message if the match fails
- -> DsM ([Id], PlainCoreExpr) -- Results
+ -> DsM ([Id], CoreExpr) -- Results
-- a special case for the common ...:
-- just one Match
= flattenMatches kind matches `thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) ->
selectMatchVars arg_pats `thenDs` \ new_vars ->
- match new_vars eqns_info [] `thenDs` \ match_result ->
+ match new_vars eqns_info [] `thenDs` \ match_result ->
getSrcLocDs `thenDs` \ (src_file, src_line) ->
newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String
let
src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
- fail_expr = mkErrorCoApp result_ty str_var (src_loc_str++": "++error_string)
+ fail_expr = mkErrorApp result_ty str_var (src_loc_str++": "++error_string)
in
extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
returnDs (new_vars, result_expr)
pattern. It returns an expression.
\begin{code}
-matchSimply :: PlainCoreExpr -- Scrutinee
+matchSimply :: CoreExpr -- Scrutinee
-> TypecheckedPat -- Pattern it should match
- -> UniType -- Type of result
- -> PlainCoreExpr -- Return this if it matches
- -> PlainCoreExpr -- Return this if it does
- -> DsM PlainCoreExpr
+ -> Type -- Type of result
+ -> CoreExpr -- Return this if it matches
+ -> CoreExpr -- Return this if it does
+ -> DsM CoreExpr
-matchSimply (CoVar var) pat result_ty result_expr fail_expr
+matchSimply (Var var) pat result_ty result_expr fail_expr
= match [var] [eqn_info] [] `thenDs` \ match_result ->
extractMatchResult match_result fail_expr
where
eqn_info = EqnInfo [pat] initial_match_result
- initial_match_result = MatchResult CantFail
+ initial_match_result = MatchResult CantFail
result_ty
- (\ ignore -> result_expr)
+ (\ ignore -> result_expr)
NoMatchContext
-
+
matchSimply scrut_expr pat result_ty result_expr msg
- = newSysLocalDs (typeOfPat pat) `thenDs` \ scrut_var ->
- matchSimply (CoVar scrut_var) pat result_ty result_expr msg `thenDs` \ expr ->
- returnDs (CoLet (CoNonRec scrut_var scrut_expr) expr)
+ = newSysLocalDs (outPatType pat) `thenDs` \ scrut_var ->
+ matchSimply (Var scrut_var) pat result_ty result_expr msg `thenDs` \ expr ->
+ returnDs (Let (NonRec scrut_var scrut_expr) expr)
extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr
extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr
= mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) ->
- returnDs (CoLet (fail_bind_fn fail_expr) (match_fn if_it_fails))
+ returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
\end{code}
%************************************************************************
returnDs (eqn_info : eqn_infos)
where
flatten_match :: [TypecheckedPat] -- Reversed list of patterns encountered so far
- -> TypecheckedMatch
+ -> TypecheckedMatch
-> DsM EquationInfo
flatten_match pats_so_far (PatMatch pat match)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MatchCon where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import DsUtils(EquationInfo, MatchResult)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniqFM(UniqFM)
-matchConFamily :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[MatchCon]{Pattern-matching constructors}
\begin{code}
#include "HsVersions.h"
-module MatchCon (
- matchConFamily
-) where
-
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
-
-import AbsUniType ( mkTyVarTy, splitType, TyVar, TyVarTemplate,
- getTyConDataCons,
- instantiateTauTy, TyCon, Class, UniType,
- TauType(..), InstTyEnv(..)
- IF_ATTACK_PRAGMAS(COMMA instantiateTy)
- )
+module MatchCon ( matchConFamily ) where
+
+import Ubiq
+import DsLoop ( match ) -- break match-ish loop
+
+import HsSyn ( OutPat(..), HsLit, HsExpr )
+import DsHsSyn ( outPatType )
+
+import DsMonad
import DsUtils
-import Id ( eqId, getInstantiatedDataConSig,
- getIdUniType, isDataCon, DataCon(..)
- )
-import Maybes ( Maybe(..) )
-import Match ( match )
-import Util
-\end{code}
-\subsection[matchConFamily]{Making alternatives for a constructor family}
+import Id ( isDataCon, GenId{-instances-} )
+import Util ( panic, assertPanic )
+\end{code}
We are confronted with the first column of patterns in a set of
equations, all beginning with constructors from one ``family'' (e.g.,
@[]@ and @:@ make up the @List@ ``family''). We want to generate the
-alternatives for a @CoCase@ expression. There are several choices:
+alternatives for a @Case@ expression. There are several choices:
\begin{enumerate}
\item
Generate an alternative for every constructor in the family, whether
chapter does.
\begin{description}
\item[Advantages:]
-(a)~Simple. (b)~It may also be that large sparsely-used constructor families are mainly
-handled by the code for literals.
+(a)~Simple. (b)~It may also be that large sparsely-used constructor
+families are mainly handled by the code for literals.
\item[Disadvantages:]
-(a)~Not practical for large sparsely-used constructor families, e.g., the
-ASCII character set. (b)~Have to look up (in the TDE environment) a
-list of what constructors make up the whole family. So far, this is
-the only part of desugaring that needs information from the environments.
+(a)~Not practical for large sparsely-used constructor families, e.g.,
+the ASCII character set. (b)~Have to look up a list of what
+constructors make up the whole family.
\end{description}
\item
\end{description}
\end{enumerate}
-We are implementing the ``do-it-right'' option for now.
-The arguments to @matchConFamily@ are the same as to @match@; the extra
-@Int@ returned is the number of constructors in the family.
+We are implementing the ``do-it-right'' option for now. The arguments
+to @matchConFamily@ are the same as to @match@; the extra @Int@
+returned is the number of constructors in the family.
The function @matchConFamily@ is concerned with this
-have-we-used-all-the-constructors question; the local function
+have-we-used-all-the-constructors? question; the local function
@match_cons_used@ does all the real work.
\begin{code}
matchConFamily :: [Id]
mkCoAlgCaseMatchResult var alts
\end{code}
-And here is the local function that does all the work. It is more-or-less the
-@matchCon@/@matchClause@ functions on page~94 in Wadler's chapter in SLPJ.
+And here is the local function that does all the work. It is
+more-or-less the @matchCon@/@matchClause@ functions on page~94 in
+Wadler's chapter in SLPJ.
\begin{code}
match_cons_used _ [{- no more eqns -}] _ = returnDs []
selectMatchVars arg_pats `thenDs` \ new_vars ->
-- Now do the business to make the alt for _this_ ConPat ...
- match (new_vars++vars)
- (map shift_con_pat eqns_for_this_con)
+ match (new_vars++vars)
+ (map shift_con_pat eqns_for_this_con)
(map shift_con_pat shadows_for_this_con) `thenDs` \ match_result ->
returnDs (
where
splitByCon :: [EquationInfo] -> ([EquationInfo], [EquationInfo])
splitByCon [] = ([],[])
- splitByCon (info@(EqnInfo (pat : _) _) : rest)
+ splitByCon (info@(EqnInfo (pat : _) _) : rest)
= case pat of
- ConPat n _ _ | n `eqId` data_con -> (info:rest_yes, rest_no)
- WildPat _ -> (info:rest_yes, info:rest_no)
- -- WildPats will be in the shadows only,
+ ConPat n _ _ | n == data_con -> (info:rest_yes, rest_no)
+ WildPat _ -> (info:rest_yes, info:rest_no)
+ -- WildPats will be in the shadows only,
-- and they go into both groups
- other_pat -> (rest_yes, info:rest_no)
+ other_pat -> (rest_yes, info:rest_no)
where
(rest_yes, rest_no) = splitByCon rest
shift_con_pat (EqnInfo (ConPat _ _ pats': pats) match_result)
= EqnInfo (pats' ++ pats) match_result
shift_con_pat (EqnInfo (WildPat _: pats) match_result) -- Will only happen in shadow
- = EqnInfo ([WildPat (typeOfPat arg_pat) | arg_pat <- arg_pats] ++ pats) match_result
+ = EqnInfo ([WildPat (outPatType arg_pat) | arg_pat <- arg_pats] ++ pats) match_result
shift_con_pat other = panic "matchConFamily:match_cons_used:shift_con_pat"
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MatchLit where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreExpr)
-import DsMonad(DsMatchContext)
-import DsUtils(EquationInfo, MatchResult)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import UniqFM(UniqFM)
-matchLiterals :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[MatchLit]{Pattern-matching literal and n+k patterns}
+\section[MatchLit]{Pattern-matching literal patterns}
\begin{code}
#include "HsVersions.h"
-module MatchLit (
- matchLiterals
- ) where
+module MatchLit ( matchLiterals ) where
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
+import Ubiq
+import DsLoop -- break match-ish and dsExpr-ish loops
-import AbsUniType ( isPrimType, getUniDataTyCon, kindFromType )
-import BasicLit ( mkMachInt, BasicLit(..), PrimKind )
-import DsExpr ( dsExpr )
+import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
+ Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
+import TcHsSyn ( TypecheckedHsExpr(..) )
+import CoreSyn ( CoreExpr(..) )
+
+import DsMonad
import DsUtils
-import Maybes ( Maybe(..), catMaybes )
-import Match ( match )
-import Id ( getIdUniType, eqId )
-import Util
+
+import Literal ( mkMachInt, Literal(..) )
+import Maybes ( catMaybes )
+import Type ( isPrimType )
+import Util ( panic, assertPanic )
\end{code}
\begin{code}
where
match_prims_used _ [{-no more eqns-}] _ = returnDs []
- match_prims_used vars eqns_info@(EqnInfo ((LitPat literal _):ps1) _ : eqns) shadows
+ match_prims_used vars eqns_info@(EqnInfo ((LitPat literal lit_ty):ps1) _ : eqns) shadows
= let
(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
- = partitionEqnsByLit Nothing literal eqns_info
+ = partitionEqnsByLit literal eqns_info
(shifted_shadows_for_this_lit, shadows_not_for_this_lit)
- = partitionEqnsByLit Nothing literal shadows
+ = partitionEqnsByLit literal shadows
in
-- recursive call to make other alts...
match_prims_used vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ rest_of_alts ->
-- now do the business to make the alt for _this_ LitPat ...
match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ match_result ->
returnDs (
- (mk_core_lit literal, match_result)
+ (mk_core_lit lit_ty literal, match_result)
: rest_of_alts
)
where
- mk_core_lit :: Literal -> BasicLit
-
- mk_core_lit (IntPrimLit i) = mkMachInt i
- mk_core_lit (CharPrimLit c) = MachChar c
- mk_core_lit (StringPrimLit s) = MachStr s
- mk_core_lit (FloatPrimLit f) = MachFloat f
- mk_core_lit (DoublePrimLit d) = MachDouble d
- mk_core_lit (LitLitLit s t) = ASSERT(isPrimType t)
- MachLitLit s (kindFromType t)
- mk_core_lit other = panic "matchLiterals:mk_core_lit:unhandled"
+ mk_core_lit :: Type -> HsLit -> Literal
+
+ mk_core_lit ty (HsIntPrim i) = mkMachInt i
+ mk_core_lit ty (HsCharPrim c) = MachChar c
+ mk_core_lit ty (HsStringPrim s) = MachStr s
+ mk_core_lit ty (HsFloatPrim f) = MachFloat f
+ mk_core_lit ty (HsDoublePrim d) = MachDouble d
+ mk_core_lit ty (HsLitLit s) = ASSERT(isPrimType ty)
+ MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; primRepFromType???")
+ mk_core_lit ty other = panic "matchLiterals:mk_core_lit:unhandled"
\end{code}
\begin{code}
matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPat literal lit_ty eq_chk):ps1) _ : eqns) shadows
= let
(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
- = partitionEqnsByLit Nothing literal eqns_info
+ = partitionEqnsByLit literal eqns_info
(shifted_shadows_for_this_lit, shadows_not_for_this_lit)
- = partitionEqnsByLit Nothing literal shadows
+ = partitionEqnsByLit literal shadows
in
- dsExpr (App eq_chk (Var var)) `thenDs` \ pred_expr ->
+ dsExpr (HsApp eq_chk (HsVar var)) `thenDs` \ pred_expr ->
match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result ->
mkGuardedMatchResult pred_expr inner_match_result `thenDs` \ match_result1 ->
if (null eqns_not_for_this_lit)
- then
+ then
returnDs match_result1
- else
+ else
matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ match_result2 ->
combineMatchResults match_result1 match_result2
\end{code}
<try-next-pattern-or-whatever>
\end{verbatim}
-\begin{code}
-matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPlusKPat master_n k ty from_lit ge sub):ps1) _ : eqns) shadows
- = let
- (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
- = partitionEqnsByLit (Just master_n) k eqns_info
- (shifted_shadows_for_this_lit, shadows_not_for_this_lit)
- = partitionEqnsByLit (Just master_n) k shadows
- in
- match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result ->
-
- dsExpr from_lit `thenDs` \ core_lit ->
- dsExpr (App ge (Var var)) `thenDs` \ var_ge ->
- dsExpr (App sub (Var var)) `thenDs` \ var_sub ->
- mkCoAppDs var_ge core_lit `thenDs` \ var_ge_lit ->
- mkCoAppDs var_sub core_lit `thenDs` \ var_sub_lit ->
-
- mkGuardedMatchResult
- var_ge_lit
- (mkCoLetsMatchResult [CoNonRec master_n var_sub_lit] inner_match_result)
- `thenDs` \ match_result1 ->
-
- if (null eqns_not_for_this_lit)
- then
- returnDs match_result1
- else
- matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ match_result2 ->
- combineMatchResults match_result1 match_result2
-\end{code}
-
-Given a blob of LitPats/NPats/NPlusKPats, we want to split them into those
+Given a blob of LitPats/NPats, we want to split them into those
that are ``same''/different as one we are looking at. We need to know
-whether we're looking at a LitPat/NPat or NPlusKPat (initial Bool arg is
-@True@ for the latter), and what literal we're after.
+whether we're looking at a LitPat/NPat, and what literal we're after.
\begin{code}
-partitionEqnsByLit :: Maybe Id -- (Just v) for N-plus-K patterns, where v
- -- is the "master" variable;
- -- Nothing for NPats and LitPats
- -> Literal
+partitionEqnsByLit :: HsLit
-> [EquationInfo]
-> ([EquationInfo], -- These ones are for this lit, AND
-- they've been "shifted" by stripping
-- are exactly as fed in.
)
-partitionEqnsByLit want_NPlusK lit eqns
+partitionEqnsByLit lit eqns
= ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
- (unzip (map (partition_eqn want_NPlusK lit) eqns))
+ (unzip (map (partition_eqn lit) eqns))
where
- partition_eqn :: Maybe Id -> Literal -> EquationInfo ->
+ partition_eqn :: HsLit -> EquationInfo ->
(Maybe EquationInfo, Maybe EquationInfo)
- partition_eqn Nothing lit (EqnInfo (LitPat k _ : remaining_pats) match_result)
+ partition_eqn lit (EqnInfo (LitPat k _ : remaining_pats) match_result)
| lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing)
-- NB the pattern is stripped off thhe EquationInfo
- partition_eqn Nothing lit (EqnInfo (NPat k _ _ : remaining_pats) match_result)
+ partition_eqn lit (EqnInfo (NPat k _ _ : remaining_pats) match_result)
| lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing)
-- NB the pattern is stripped off thhe EquationInfo
- partition_eqn (Just master_n) lit (EqnInfo (NPlusKPat n k _ _ _ _ : remaining_pats) match_result)
- | lit `eq_lit` k = (Just (EqnInfo remaining_pats new_match_result), Nothing)
- -- NB the pattern is stripped off thhe EquationInfo
- where
- new_match_result = if master_n `eqId` n then
- match_result
- else
- mkCoLetsMatchResult [CoNonRec n (CoVar master_n)] match_result
-
-- Wild-card patterns, which will only show up in the shadows, go into both groups
- partition_eqn wantNPlusK lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result)
+ partition_eqn lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result)
= (Just (EqnInfo remaining_pats match_result), Just eqn)
-- Default case; not for this pattern
- partition_eqn wantNPlusK lit eqn = (Nothing, Just eqn)
+ partition_eqn lit eqn = (Nothing, Just eqn)
-- ToDo: meditate about this equality business...
-eq_lit (IntLit i1) (IntLit i2) = i1 == i2
-eq_lit (FracLit f1) (FracLit f2) = f1 == f2
-
-eq_lit (IntPrimLit i1) (IntPrimLit i2) = i1 == i2
-eq_lit (FloatPrimLit f1) (FloatPrimLit f2) = f1 == f2
-eq_lit (DoublePrimLit d1) (DoublePrimLit d2) = d1 == d2
-eq_lit (CharLit c1) (CharLit c2) = c1 == c2
-eq_lit (CharPrimLit c1) (CharPrimLit c2) = c1 == c2
-eq_lit (StringLit s1) (StringLit s2) = s1 == s2
-eq_lit (StringPrimLit s1) (StringPrimLit s2) = s1 == s2
-eq_lit (LitLitLit s1 _) (LitLitLit s2 _) = s1 == s2 -- ToDo: ??? (dubious)
-eq_lit other1 other2 = panic "matchLiterals:eq_lit"
+eq_lit (HsInt i1) (HsInt i2) = i1 == i2
+eq_lit (HsFrac f1) (HsFrac f2) = f1 == f2
+
+eq_lit (HsIntPrim i1) (HsIntPrim i2) = i1 == i2
+eq_lit (HsFloatPrim f1) (HsFloatPrim f2) = f1 == f2
+eq_lit (HsDoublePrim d1) (HsDoublePrim d2) = d1 == d2
+eq_lit (HsChar c1) (HsChar c2) = c1 == c2
+eq_lit (HsCharPrim c1) (HsCharPrim c2) = c1 == c2
+eq_lit (HsString s1) (HsString s2) = s1 == s2
+eq_lit (HsStringPrim s1) (HsStringPrim s2) = s1 == s2
+eq_lit (HsLitLit s1) (HsLitLit s2) = s1 == s2 -- ToDo: ??? (dubious)
+eq_lit other1 other2 = panic "matchLiterals:eq_lit"
\end{code}
+++ /dev/null
-% Filename: %M%
-% Version : %I%
-% Date : %G%
-%
-\section[MatchProcessors]{Pattern-matching processors}
-\begin{code}
-module MatchProc (
- matchProcessor
-) where
-
-#include "HsVersions.h"
-
-import AbsSyn -- the stuff being desugared
-import PlainCore -- the output of desugaring;
- -- importing this module also gets all the
- -- CoreSyn utility functions
-import DsMonad -- the monadery used in the desugarer
-
-import AbsUniType ( mkTyVarTy, splitType, mkProcessorTyCon,
- TyVar, TyCon, Class, UniType,
- TauType(..)
- )
-import DsUtils ( EquationInfo(..), selectMatchVars )
-import Id ( getDataConFamily, getDataConTyCon,
- getIdUniType, mkProcessorCon
- )
-import ListSetOps ( minusList )
-import Maybes ( Maybe(..) )
-import Match ( match )
-import Util
-import DsExpr ( dsExpr)
-\end{code}
-
-The matching of processors is based upon that of constructors. Given the
-pattern :
-\begin{verbatim}
- (|x1,..xn;y|)
-\end{verbatim}
-
-The pattern matching compiler converts the above into :
-\begin{verbatim}
- case x of
- (|u1,..un;uy|) -> let x1 = fromDomain u_1 of
- ....
- let xn = fromDomain u_n of
- let y = fromDomain uy of
- PATTERN MATCH REST
-\end{verbatim}
-
-\begin{code}
-matchProcessor :: [Id]
- -> [EquationInfo]
- -> PlainCoreExpr
- -> DsM PlainCoreExpr
-
-matchProcessor (v:vs) eqnInfo ifFail
- = selectMatchVars [pat] `thenDs` (\ [var] ->
- selectMatchVars pats `thenDs` (\ vars ->
- match (var:vs)
- [(pat:ps,after_fun)]
- ifFail `thenDs` (\ body ->
- create_lets vars pats convs body ifFail `thenDs` (\ rhs ->
- returnDs (
- CoCase
- (CoVar v)
- (CoAlgAlts
- [((mkProcessorCon podSize),vars++[var], rhs)]
- CoNoDefault))
- ))))
- where
- podSize = (length pats)
- -- Sanity checking pattern match. Product type of processors ensures
- -- there can be only one result if the equations are properly unmixed.
- ((ProcessorPat pats convs pat):ps,after_fun)
- | length eqnInfo == 1 = head eqnInfo
- | otherwise = panic "matchProcessor more than one"
-
-\end{code}
-
-\begin{code}
-create_lets::[Id] ->
- [TypecheckedPat] ->
- [TypecheckedExpr] ->
- PlainCoreExpr ->
- PlainCoreExpr ->
- (DsM PlainCoreExpr)
-
-create_lets [] _ _ body _ = returnDs (body)
-create_lets (v:vs) (p:ps) (c:cs) body ifFail
- = selectMatchVars [p] `thenDs` (\ var ->
- create_lets vs ps cs body ifFail `thenDs` (\ after ->
- dsExpr c `thenDs` (\ c' ->
- match var
- [([p], \x -> after)]
- ifFail `thenDs` (\ exp ->
- returnDs ( CoApp (CoLam var exp) (CoApp c' (CoVar v))) ))))
-\end{code}
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface Core2Def where
-import BinderInfo(BinderInfo)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding, CoreExpr)
-import DefSyn(DefBindee, DefProgram(..))
-import Id(Id)
-import PlainCore(PlainCoreProgram(..))
-import UniqFM(UniqFM)
-data CoreBinding a b
-data DefBindee
-type DefProgram = [CoreBinding Id DefBindee]
-data Id
-type PlainCoreProgram = [CoreBinding Id Id]
-c2d :: UniqFM (CoreExpr Id DefBindee) -> CoreExpr (Id, BinderInfo) Id -> CoreExpr Id DefBindee
-core2def :: (GlobalSwitch -> SwitchResult) -> [CoreBinding Id Id] -> [CoreBinding Id DefBindee]
-
>#include "HsVersions.h"
>
-> module Core2Def (
+> module Core2Def (
> core2def, c2d,
->
-> PlainCoreProgram(..), DefProgram(..),
-> CoreBinding, Id, DefBindee ) where
->
+>
+> DefProgram(..),
+> GenCoreBinding, Id, DefBindee ) where
+>
> import DefSyn
->#ifdef __HBC__
-> import Trace
->#endif
> import CoreSyn
-> import IdEnv
-> import PlainCore
-> import TaggedCore
> import BinderInfo -- ( BinderInfo(..), isFun, isDupDanger )
> import CmdLineOpts ( switchIsOn, SwitchResult, SimplifierSwitch )
> import OccurAnal ( occurAnalyseBinds )
> import Pretty
> import Outputable
-This module translates the PlainCoreProgram into a DefCoreProgram,
+This module translates the CoreProgram into a DefCoreProgram,
which includes non-atomic right-hand sides. The decisions about which
expressions to inline are left to the substitution analyser, which we
run beforehand.
2. We don't inline top-level lets that occur only once, because these
might not be pulled out again by the let-floater, due to non-
- garbage collection of CAFs.
+ garbage collection of CAFs.
2.1. Also, what about these lit things that occur at the top level,
and are usually marked as macros?
3. No recusrive functions are unfolded.
ToDo:
-4. Lambdas and case alternatives that bind a variable that occurs
+4. Lambdas and case alternatives that bind a variable that occurs
multiple times are transformed:
\x -> ..x..x.. ===> \x -> let x' = x in ..x'..x'..
-> core2def :: (GlobalSwitch -> SwitchResult) -> PlainCoreProgram -> DefProgram
-> core2def sw prog =
+> core2def :: (GlobalSwitch -> SwitchResult) -> [CoreBinding] -> DefProgram
+> core2def sw prog =
> map coreBinding2def tagged_program
-> where
+> where
> tagged_program = occurAnalyseBinds prog switch_is_on (const False)
> switch_is_on = switchIsOn sw
> coreBinding2def :: SimplifiableCoreBinding -> DefBinding
-> coreBinding2def (CoNonRec (v,_) e) = CoNonRec v (c2d nullIdEnv e)
-> coreBinding2def (CoRec bs) = CoRec (map recBind2def bs)
+> coreBinding2def (NonRec (v,_) e) = NonRec v (c2d nullIdEnv e)
+> coreBinding2def (Rec bs) = Rec (map recBind2def bs)
> where recBind2def ((v,_),e) = (v, c2d nullIdEnv e)
-> coreAtom2def :: IdEnv DefExpr -> PlainCoreAtom -> DefAtom
-> coreAtom2def p (CoVarAtom v) = CoVarAtom (DefArgExpr (lookup p v))
-> coreAtom2def p (CoLitAtom l) = CoVarAtom (DefArgExpr (CoLit l))
+> coreAtom2def :: IdEnv DefExpr -> CoreArg -> DefAtom
+> coreAtom2def p (VarArg v) = VarArg (DefArgExpr (lookup p v))
+> coreAtom2def p (LitArg l) = VarArg (DefArgExpr (Lit l))
-> isTrivial (CoCon c [] []) = True
-> isTrivial (CoVar v) = True
-> isTrivial (CoLit l) = True
+> isTrivial (Con c [] []) = True
+> isTrivial (Var v) = True
+> isTrivial (Lit l) = True
> isTrivial _ = False
> c2d :: IdEnv DefExpr -> SimplifiableCoreExpr -> DefExpr
> c2d p e = case e of
->
-> CoVar v -> lookup p v
->
-> CoLit l -> CoLit l
->
-> CoCon c ts es -> CoCon c ts (map (coreAtom2def p) es)
->
-> CoPrim op ts es -> CoPrim op ts (map (coreAtom2def p) es)
->
-> CoLam vs e -> CoLam (map fst vs) (c2d p e)
->
+>
+> Var v -> lookup p v
+>
+> Lit l -> Lit l
+>
+> Con c ts es -> Con c ts (map (coreAtom2def p) es)
+>
+> Prim op ts es -> Prim op ts (map (coreAtom2def p) es)
+>
+> Lam vs e -> Lam (map fst vs) (c2d p e)
+>
> CoTyLam alpha e -> CoTyLam alpha (c2d p e)
->
-> CoApp e v -> CoApp (c2d p e) (coreAtom2def p v)
->
+>
+> App e v -> App (c2d p e) (coreAtom2def p v)
+>
> CoTyApp e t -> CoTyApp (c2d p e) t
->
-> CoCase e ps -> CoCase (c2d p e) (coreCaseAlts2def p ps)
->
-> CoLet (CoNonRec (v,ManyOcc _) e) e'
+>
+> Case e ps -> Case (c2d p e) (coreCaseAlts2def p ps)
+>
+> Let (NonRec (v,ManyOcc _) e) e'
> | isTrivial e -> c2d (addOneToIdEnv p v (c2d p e)) e'
> | otherwise ->
> trace ("Not inlining ManyOcc " ++ ppShow 80 (ppr PprDebug v)) (
-> CoLet (CoNonRec v (c2d p e)) (c2d p e'))
->
-> CoLet (CoNonRec (v,DeadCode) e) e' ->
+> Let (NonRec v (c2d p e)) (c2d p e'))
+>
+> Let (NonRec (v,DeadCode) e) e' ->
> panic "Core2Def(c2d): oops, unexpected DeadCode"
->
-> CoLet (CoNonRec (v,OneOcc fun_or_arg dup_danger _ _ _) e) e'
+>
+> Let (NonRec (v,OneOcc fun_or_arg dup_danger _ _ _) e) e'
> | isTrivial e -> inline_it
> | isDupDanger dup_danger ->
> trace ("Not inlining DupDanger " ++ ppShow 80 (ppr PprDebug v))(
-> CoLet (CoNonRec v (c2d p e)) (c2d p e'))
+> Let (NonRec v (c2d p e)) (c2d p e'))
> | isFun fun_or_arg ->
> panic "Core2Def(c2d): oops, unexpected Macro"
> | otherwise -> inline_it
> where inline_it = c2d (addOneToIdEnv p v (c2d p e)) e'
->
-> CoLet (CoRec bs) e -> CoLet (CoRec (map recBind2def bs)) (c2d p e)
+>
+> Let (Rec bs) e -> Let (Rec (map recBind2def bs)) (c2d p e)
> where recBind2def ((v,_),e) = (v, c2d p e)
->
-> CoSCC l e -> CoSCC l (c2d p e)
+>
+> SCC l e -> SCC l (c2d p e)
-> coreCaseAlts2def
-> :: IdEnv DefExpr
-> -> SimplifiableCoreCaseAlternatives
+> coreCaseAlts2def
+> :: IdEnv DefExpr
+> -> SimplifiableCoreCaseAlts
> -> DefCaseAlternatives
->
+>
> coreCaseAlts2def p alts = case alts of
-> CoAlgAlts as def -> CoAlgAlts (map algAlt2def as) (defAlt2def def)
-> CoPrimAlts as def -> CoPrimAlts (map primAlt2def as) (defAlt2def def)
->
-> where
->
+> AlgAlts as def -> AlgAlts (map algAlt2def as) (defAlt2def def)
+> PrimAlts as def -> PrimAlts (map primAlt2def as) (defAlt2def def)
+>
+> where
+>
> algAlt2def (c, vs, e) = (c, (map fst vs), c2d p e)
> primAlt2def (l, e) = (l, c2d p e)
-> defAlt2def CoNoDefault = CoNoDefault
-> defAlt2def (CoBindDefault (v,_) e) = CoBindDefault v (c2d p e)
+> defAlt2def NoDefault = NoDefault
+> defAlt2def (BindDefault (v,_) e) = BindDefault v (c2d p e)
> lookup :: IdEnv DefExpr -> Id -> DefExpr
> lookup p v = case lookupIdEnv p v of
-> Nothing -> CoVar (DefArgVar v)
+> Nothing -> Var (DefArgVar v)
> Just e -> e
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface Cyclic where
-import CoreSyn(CoreExpr)
-import DefSyn(DefBindee)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-fixupFreeVars :: [Id] -> Id -> CoreExpr Id DefBindee -> ((Id, CoreExpr Id DefBindee), [(Id, CoreExpr Id DefBindee)])
-mkLoops :: CoreExpr Id DefBindee -> SplitUniqSupply -> ([(Id, CoreExpr Id DefBindee)], CoreExpr Id DefBindee)
-
> ) where
> import DefSyn
-> import PlainCore
> import DefUtils
> import Def2Core ( d2c, defPanic )
->#ifdef __HBC__
-> import Trace
->#endif
-> import AbsUniType ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTy,
+> import Type ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTy,
> TyVarTemplate
> )
> import Digraph ( dfs )
-> import Id ( getIdUniType, toplevelishId, updateIdType,
+> import Id ( idType, toplevelishId, updateIdType,
> getIdInfo, replaceIdInfo, eqId, Id
> )
> import IdInfo
> import Maybes ( Maybe(..) )
> import Outputable
> import Pretty
-> import SplitUniq
+> import UniqSupply
> import Util
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
Monad for the knot-tier.
-> type Lbl a = SUniqSM (
+> type Lbl a = UniqSM (
> [(Id)], -- loops used
> [(Id,DefExpr,[Id],DefExpr)], -- bindings floating upwards
> [(Id,DefExpr)], -- back loops
> a) -- computation result
->
+>
> thenLbl :: Lbl a -> (a -> Lbl b) -> Lbl b
> thenLbl a k
-> = a `thenSUs` \(ls, bs, bls, a) ->
-> k a `thenSUs` \(ls',bs',bls', b) ->
-> returnSUs (ls ++ ls', bs ++ bs', bls ++ bls', b)
->
+> = a `thenUs` \(ls, bs, bls, a) ->
+> k a `thenUs` \(ls',bs',bls', b) ->
+> returnUs (ls ++ ls', bs ++ bs', bls ++ bls', b)
+>
> returnLbl :: a -> Lbl a
-> returnLbl a = returnSUs ([],[],[],a)
->
+> returnLbl a = returnUs ([],[],[],a)
+>
> mapLbl :: (a -> Lbl b) -> [a] -> Lbl [b]
> mapLbl f [] = returnLbl []
> mapLbl f (x:xs)
This is terribly inefficient.
-> mkLoops :: DefExpr -> SUniqSM ([(Id,DefExpr)],DefExpr)
-> mkLoops e =
+> mkLoops :: DefExpr -> UniqSM ([(Id,DefExpr)],DefExpr)
+> mkLoops e =
> error "mkLoops"
>{- LATER:
-> loop [] e `thenSUs` \(ls,bs,bls,e) ->
+> loop [] e `thenUs` \(ls,bs,bls,e) ->
Throw away all the extracted bindings that can't be reached. These
can occur as the result of some forward loops being short-circuited by
> loops_out = filter deforestable (freeVars e)
> (_,reachable) = dfs (==) r ([],[]) loops_out
> r f = lookup f bs
->
+>
> lookup f [] = []
> lookup f ((g,out,_):xs) | f == g = out
> | otherwise = lookup f xs
->
+>
> isReachable (f,_,_) = f `elem` reachable
> in
-> returnSUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e)
+> returnUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e)
> where
> loop :: [(Id,DefExpr,[Id],[TyVar])] -> DefExpr -> Lbl DefExpr
-> loop ls (CoVar (Label e e1))
-> =
-> d2c e `thenSUs` \core_e ->
+> loop ls (Var (Label e e1))
+> =
+> d2c e `thenUs` \core_e ->
>-- trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $
-> mapSUs (\(f,e',val_args,ty_args) ->
-> renameExprs e' e `thenSUs` \r ->
-> returnSUs (f,val_args,ty_args,r)) ls `thenSUs` \results ->
+> mapUs (\(f,e',val_args,ty_args) ->
+> renameExprs e' e `thenUs` \r ->
+> returnUs (f,val_args,ty_args,r)) ls `thenUs` \results ->
> let
-> loops =
-> [ (f,val_args,ty_args,r) |
+> loops =
+> [ (f,val_args,ty_args,r) |
> (f,val_args,ty_args,IsRenaming r) <- results ]
-> inconsistent_renamings =
-> [ (f,r) |
-> (f,val_args,ty_args,InconsistentRenaming r)
+> inconsistent_renamings =
+> [ (f,r) |
+> (f,val_args,ty_args,InconsistentRenaming r)
> <- results ]
> in
->
+>
> (case loops of
> [] ->
The type of a new function, if one is generated at this point, is
constructed as follows:
- \/ a1 ... \/ an . b1 -> ... -> bn -> t
+ \/ a1 ... \/ an . b1 -> ... -> bn -> t
where a1...an are the free type variables in the expression, b1...bn
are the types of the free variables in the expression, and t is the
type of the expression itself.
> let
->
+>
> -- Collect the value/type arguments for the function
> fvs = freeVars e
> val_args = filter isArgId fvs
> ty_args = freeTyVars e
->
+>
> -- Now to make up the type...
-> base_type = typeOfCoreExpr core_e
-> fun_type = glueTyArgs (map getIdUniType val_args) base_type
+> base_type = coreExprType core_e
+> fun_type = glueTyArgs (map idType val_args) base_type
> (_, type_of_f) = quantifyTy ty_args fun_type
> in
->
-> newDefId type_of_f `thenSUs` \f' ->
-> let
-> f = replaceIdInfo f'
+>
+> newDefId type_of_f `thenUs` \f' ->
+> let
+> f = replaceIdInfo f'
> (addInfo (getIdInfo f') DoDeforest)
> in
> loop ((f,e,val_args,ty_args):ls) e1
-> `thenSUs` \res@(ls',bs,bls,e') ->
+> `thenUs` \res@(ls',bs,bls,e') ->
Key: ls = loops, bs = bindings, bls = back loops, e = expression.
> let back_loops = reverse [ e | (f',e) <- bls, f' == f ] in
> if not (null back_loops){- && not (f `elem` ls')-} then
> --if length back_loops > 1 then panic "barf!" else
-> d2c (head back_loops) `thenSUs` \core_e ->
-> trace ("Back Loop:\n" ++
+> d2c (head back_loops) `thenUs` \core_e ->
+> trace ("Back Loop:\n" ++
> ppShow 80 (ppr PprDebug core_e)) $
If we find a back-loop that also occurs where we would normally make a
new function...
> if f `elem` ls' then
-> d2c e' `thenSUs` \core_e' ->
+> d2c e' `thenUs` \core_e' ->
> trace ("In Forward Loop " ++
> ppShow 80 (ppr PprDebug f) ++ "\n" ++
> ppShow 80 (ppr PprDebug core_e')) $
> if f `notElem` (freeVars (head back_loops)) then
-> returnSUs (ls', bs, bls, head back_loops)
+> returnUs (ls', bs, bls, head back_loops)
> else
> panic "hello"
> else
-> returnSUs (ls', bs, bls, head back_loops)
+> returnUs (ls', bs, bls, head back_loops)
> else
If we are in a forward-loop (i.e. we found a label somewhere below
which is a renaming of this one), then make a new function definition.
> if f `elem` ls' then
->
-> rebindExpr (mkCoTyLam ty_args (mkCoLam val_args e'))
-> `thenSUs` \rhs ->
-> returnSUs
-> (ls',
-> (f,filter deforestable (freeVars e'),e,rhs) : bs,
+>
+> rebindExpr (mkLam ty_args val_args e')
+> `thenUs` \rhs ->
+> returnUs
+> (ls',
+> (f,filter deforestable (freeVars e'),e,rhs) : bs,
> bls,
> mkLoopFunApp val_args ty_args f)
otherwise, forget about it
-> else returnSUs res
+> else returnUs res
This is a loop, just make a call to the function which we
will create on the way back up the tree.
(NB: it appears that sometimes we do get more than one loop matching,
investigate this?)
-> ((f,val_args,ty_args,r):_) ->
->
-> returnSUs
+> ((f,val_args,ty_args,r):_) ->
+>
+> returnUs
> ([f], -- found a loop, propagate it back
> [], -- no bindings
> [], -- no back loops
> mkLoopFunApp (applyRenaming r val_args) ty_args f)
->
-> ) `thenSUs` \res@(ls',bs,bls,e') ->
+>
+> ) `thenUs` \res@(ls',bs,bls,e') ->
If this expression reoccurs, record the binding and replace the cycle
with a call to the new function. We also rebind all the free
variables in the new function to avoid name clashes later.
> let
-> findBackLoops (g,r) bls
-> | consistent r' = subst s e' `thenSUs` \e' ->
-> returnSUs ((g,e') : bls)
-> | otherwise = returnSUs bls
+> findBackLoops (g,r) bls
+> | consistent r' = subst s e' `thenUs` \e' ->
+> returnUs ((g,e') : bls)
+> | otherwise = returnUs bls
> where
> r' = map swap r
-> s = map (\(x,y) -> (x, CoVar (DefArgVar y))) (nub r')
+> s = map (\(x,y) -> (x, Var (DefArgVar y))) (nub r')
> in
We just want the first one (ie. furthest up the tree), so reverse the
list of inconsistent renamings.
> foldrSUs findBackLoops [] (reverse inconsistent_renamings)
-> `thenSUs` \back_loops ->
+> `thenUs` \back_loops ->
Comment out the next block to disable back-loops. ToDo: trace all of them.
> if not (null back_loops) then
-> d2c e' `thenSUs` \core_e ->
-> trace ("Floating back loop:\n"
-> ++ ppShow 80 (ppr PprDebug core_e))
-> returnSUs (ls', bs, back_loops ++ bls, e')
+> d2c e' `thenUs` \core_e ->
+> trace ("Floating back loop:\n"
+> ++ ppShow 80 (ppr PprDebug core_e))
+> returnUs (ls', bs, back_loops ++ bls, e')
> else
-> returnSUs res
+> returnUs res
-> loop ls e@(CoVar (DefArgVar v))
+> loop ls e@(Var (DefArgVar v))
> = returnLbl e
-> loop ls e@(CoLit l)
+> loop ls e@(Lit l)
> = returnLbl e
-> loop ls (CoCon c ts es)
+> loop ls (Con c ts es)
> = mapLbl (loopAtom ls) es `thenLbl` \es ->
-> returnLbl (CoCon c ts es)
-> loop ls (CoPrim op ts es)
+> returnLbl (Con c ts es)
+> loop ls (Prim op ts es)
> = mapLbl (loopAtom ls) es `thenLbl` \es ->
-> returnLbl (CoPrim op ts es)
-> loop ls (CoLam vs e)
+> returnLbl (Prim op ts es)
+> loop ls (Lam vs e)
> = loop ls e `thenLbl` \e ->
-> returnLbl (CoLam vs e)
+> returnLbl (Lam vs e)
> loop ls (CoTyLam alpha e)
> = loop ls e `thenLbl` \e ->
> returnLbl (CoTyLam alpha e)
-> loop ls (CoApp e v)
+> loop ls (App e v)
> = loop ls e `thenLbl` \e ->
> loopAtom ls v `thenLbl` \v ->
-> returnLbl (CoApp e v)
+> returnLbl (App e v)
> loop ls (CoTyApp e t)
> = loop ls e `thenLbl` \e ->
> returnLbl (CoTyApp e t)
-> loop ls (CoCase e ps)
+> loop ls (Case e ps)
> = loop ls e `thenLbl` \e ->
> loopCaseAlts ls ps `thenLbl` \ps ->
-> returnLbl (CoCase e ps)
-> loop ls (CoLet (CoNonRec v e) e')
+> returnLbl (Case e ps)
+> loop ls (Let (NonRec v e) e')
> = loop ls e `thenLbl` \e ->
> loop ls e' `thenLbl` \e' ->
-> returnLbl (CoLet (CoNonRec v e) e')
-> loop ls (CoLet (CoRec bs) e)
+> returnLbl (Let (NonRec v e) e')
+> loop ls (Let (Rec bs) e)
> = mapLbl loopRecBind bs `thenLbl` \bs ->
> loop ls e `thenLbl` \e ->
-> returnLbl (CoLet (CoRec bs) e)
+> returnLbl (Let (Rec bs) e)
> where
> vs = map fst bs
> loopRecBind (v, e)
> loop ls e
> = defPanic "Cyclic" "loop" e
-> loopAtom ls (CoVarAtom (DefArgExpr e))
+> loopAtom ls (VarArg (DefArgExpr e))
> = loop ls e `thenLbl` \e ->
-> returnLbl (CoVarAtom (DefArgExpr e))
-> loopAtom ls (CoVarAtom e@(DefArgVar v))
-> = defPanic "Cyclic" "loopAtom" (CoVar e)
-> loopAtom ls (CoVarAtom e@(Label _ _))
-> = defPanic "Cyclic" "loopAtom" (CoVar e)
-> loopAtom ls e@(CoLitAtom l)
+> returnLbl (VarArg (DefArgExpr e))
+> loopAtom ls (VarArg e@(DefArgVar v))
+> = defPanic "Cyclic" "loopAtom" (Var e)
+> loopAtom ls (VarArg e@(Label _ _))
+> = defPanic "Cyclic" "loopAtom" (Var e)
+> loopAtom ls e@(LitArg l)
> = returnLbl e
>
-> loopCaseAlts ls (CoAlgAlts as def) =
+> loopCaseAlts ls (AlgAlts as def) =
> mapLbl loopAlgAlt as `thenLbl` \as ->
> loopDefault ls def `thenLbl` \def ->
-> returnLbl (CoAlgAlts as def)
+> returnLbl (AlgAlts as def)
> where
> loopAlgAlt (c, vs, e) =
> loop ls e `thenLbl` \e ->
> returnLbl (c, vs, e)
-> loopCaseAlts ls (CoPrimAlts as def) =
+> loopCaseAlts ls (PrimAlts as def) =
> mapLbl loopPrimAlt as `thenLbl` \as ->
> loopDefault ls def `thenLbl` \def ->
-> returnLbl (CoPrimAlts as def)
+> returnLbl (PrimAlts as def)
> where
-> loopPrimAlt (l, e) =
+> loopPrimAlt (l, e) =
> loop ls e `thenLbl` \e ->
> returnLbl (l, e)
-> loopDefault ls CoNoDefault =
-> returnLbl CoNoDefault
-> loopDefault ls (CoBindDefault v e) =
+> loopDefault ls NoDefault =
+> returnLbl NoDefault
+> loopDefault ls (BindDefault v e) =
> loop ls e `thenLbl` \e ->
-> returnLbl (CoBindDefault v e)
+> returnLbl (BindDefault v e)
> -}
-> mkVar v = CoVarAtom (DefArgExpr (CoVar (DefArgVar v)))
+> mkVar v = VarArg (DefArgExpr (Var (DefArgVar v)))
-----------------------------------------------------------------------------
The next function is applied to all deforestable functions which are
> case fvs of
> [] -> ((id,e),[])
> _ -> let new_type =
-> glueTyArgs (map getIdUniType fvs)
-> (getIdUniType id)
+> glueTyArgs (map idType fvs)
+> (idType id)
> new_id =
> updateIdType id new_type
> in
> let
-> t = foldl CoApp (CoVar (DefArgVar new_id))
+> t = foldl App (Var (DefArgVar new_id))
> (map mkVar fvs)
> in
> trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $
-> ((new_id, mkCoLam fvs e), [(id,t)])
+> ((new_id, mkValLam fvs e), [(id,t)])
> where
> fvs = case e of
-> CoLam bvs e -> filter (`notElem` bvs) total_fvs
+> Lam bvs e -> filter (`notElem` bvs) total_fvs
> _ -> total_fvs
> swap (x,y) = (y,x)
> mkLoopFunApp :: [Id] -> [TyVar] -> Id -> DefExpr
> mkLoopFunApp val_args ty_args f =
-> foldl CoApp
-> (foldl CoTyApp (CoVar (DefArgVar f))
+> foldl App
+> (foldl CoTyApp (Var (DefArgVar f))
> (map mkTyVarTy ty_args))
> (map mkVar val_args)
> removeDuplicateDefinitions
> :: [(DefExpr,(Id,DefExpr))] -- (label,(id,rhs))
-> -> SUniqSM [(Id,DefExpr)]
+> -> UniqSM [(Id,DefExpr)]
-> removeDuplicateDefinitions defs =
-> foldrSUs rem ([],[]) defs `thenSUs` \(newdefs,s) ->
-> mapSUs (\(l,(f,e)) -> subst s e `thenSUs` \e ->
-> returnSUs (f, e)) newdefs
-> where
+> removeDuplicateDefinitions defs =
+> foldrSUs rem ([],[]) defs `thenUs` \(newdefs,s) ->
+> mapUs (\(l,(f,e)) -> subst s e `thenUs` \e ->
+> returnUs (f, e)) newdefs
+> where
> rem d@(l,(f,e)) (defs,s) =
-> findDup l defs `thenSUs` \maybe ->
+> findDup l defs `thenUs` \maybe ->
> case maybe of
-> Nothing -> returnSUs (d:defs,s)
-> Just g -> returnSUs (defs, (f,(CoVar.DefArgVar) g):s)
+> Nothing -> returnUs (d:defs,s)
+> Just g -> returnUs (defs, (f,(Var.DefArgVar) g):s)
We insist that labels rename in both directions, is this necessary?
-> findDup l [] = returnSUs Nothing
+> findDup l [] = returnUs Nothing
> findDup l ((l',(f,e)):defs) =
-> renameExprs l l' `thenSUs` \r ->
+> renameExprs l l' `thenUs` \r ->
> case r of
-> IsRenaming _ -> renameExprs l' l `thenSUs` \r ->
+> IsRenaming _ -> renameExprs l' l `thenUs` \r ->
> case r of
-> IsRenaming r -> returnSUs (Just f)
+> IsRenaming r -> returnUs (Just f)
> _ -> findDup l defs
> _ -> findDup l defs
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface Def2Core where
-import CoreSyn(CoreBinding, CoreExpr)
-import DefSyn(DefBindee, DefBinding(..))
-import Id(Id)
-import PlainCore(PlainCoreProgram(..))
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-data CoreBinding a b
-data DefBindee
-type DefBinding = CoreBinding Id DefBindee
-data Id
-type PlainCoreProgram = [CoreBinding Id Id]
-type SUniqSM a = SplitUniqSupply -> a
-d2c :: CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id Id
-def2core :: [CoreBinding Id DefBindee] -> SplitUniqSupply -> [CoreBinding Id Id]
-defPanic :: [Char] -> [Char] -> CoreExpr Id DefBindee -> SplitUniqSupply -> a
-
>#include "HsVersions.h"
>
-> module Def2Core (
+> module Def2Core (
> def2core, d2c,
->
+>
> -- and to make the interface self-sufficient, all this stuff:
-> DefBinding(..), SUniqSM(..), PlainCoreProgram(..),
-> CoreBinding, Id, DefBindee,
+> DefBinding(..), UniqSM(..),
+> GenCoreBinding, Id, DefBindee,
> defPanic
> ) where
> import DefSyn
> import DefUtils
->
+>
> import Maybes ( Maybe(..) )
> import Outputable
-> import PlainCore
> import Pretty
-> import SplitUniq
+> import UniqSupply
> import Util
-> def2core :: DefProgram -> SUniqSM PlainCoreProgram
-> def2core prog = mapSUs defBinding2core prog
+> def2core :: DefProgram -> UniqSM [CoreBinding]
+> def2core prog = mapUs defBinding2core prog
-> defBinding2core :: DefBinding -> SUniqSM PlainCoreBinding
-> defBinding2core (CoNonRec v e) =
-> d2c e `thenSUs` \e' ->
-> returnSUs (CoNonRec v e')
-> defBinding2core (CoRec bs) =
-> mapSUs recBind2core bs `thenSUs` \bs' ->
-> returnSUs (CoRec bs')
-> where recBind2core (v,e)
-> = d2c e `thenSUs` \e' ->
-> returnSUs (v, e')
+> defBinding2core :: DefBinding -> UniqSM CoreBinding
+> defBinding2core (NonRec v e) =
+> d2c e `thenUs` \e' ->
+> returnUs (NonRec v e')
+> defBinding2core (Rec bs) =
+> mapUs recBind2core bs `thenUs` \bs' ->
+> returnUs (Rec bs')
+> where recBind2core (v,e)
+> = d2c e `thenUs` \e' ->
+> returnUs (v, e')
-> defAtom2core :: DefAtom -> SUniqSM (PlainCoreAtom, Maybe PlainCoreExpr)
+> defAtom2core :: DefAtom -> UniqSM (CoreArg, Maybe CoreExpr)
> defAtom2core atom = case atom of
-> CoLitAtom l -> returnSUs (CoLitAtom l, Nothing)
-> CoVarAtom (DefArgVar id) -> returnSUs (CoVarAtom id, Nothing)
-> CoVarAtom (DefArgExpr (CoVar (DefArgVar id))) ->
-> returnSUs (CoVarAtom id, Nothing)
-> CoVarAtom (DefArgExpr (CoLit l)) ->
-> returnSUs (CoLitAtom l, Nothing)
-> CoVarAtom (DefArgExpr e) ->
-> d2c e `thenSUs` \e' ->
-> newTmpId (typeOfCoreExpr e') `thenSUs` \new_id ->
-> returnSUs (CoVarAtom new_id, Just e')
-> CoVarAtom (Label _ _) ->
-> panic "Def2Core(defAtom2core): CoVarAtom (Label _ _)"
+> LitArg l -> returnUs (LitArg l, Nothing)
+> VarArg (DefArgVar id) -> returnUs (VarArg id, Nothing)
+> VarArg (DefArgExpr (Var (DefArgVar id))) ->
+> returnUs (VarArg id, Nothing)
+> VarArg (DefArgExpr (Lit l)) ->
+> returnUs (LitArg l, Nothing)
+> VarArg (DefArgExpr e) ->
+> d2c e `thenUs` \e' ->
+> newTmpId (coreExprType e') `thenUs` \new_id ->
+> returnUs (VarArg new_id, Just e')
+> VarArg (Label _ _) ->
+> panic "Def2Core(defAtom2core): VarArg (Label _ _)"
-> d2c :: DefExpr -> SUniqSM PlainCoreExpr
+> d2c :: DefExpr -> UniqSM CoreExpr
> d2c e = case e of
->
-> CoVar (DefArgExpr e) ->
-> panic "Def2Core(d2c): CoVar (DefArgExpr _)"
->
-> CoVar (Label _ _) ->
-> panic "Def2Core(d2c): CoVar (Label _ _)"
->
-> CoVar (DefArgVar v) ->
-> returnSUs (CoVar v)
->
-> CoLit l ->
-> returnSUs (CoLit l)
->
-> CoCon c ts as ->
-> mapSUs defAtom2core as `thenSUs` \atom_expr_pairs ->
-> returnSUs (
-> foldr (\(a,b) -> mkLet a b)
-> (CoCon c ts (map fst atom_expr_pairs))
+>
+> Var (DefArgExpr e) ->
+> panic "Def2Core(d2c): Var (DefArgExpr _)"
+>
+> Var (Label _ _) ->
+> panic "Def2Core(d2c): Var (Label _ _)"
+>
+> Var (DefArgVar v) ->
+> returnUs (Var v)
+>
+> Lit l ->
+> returnUs (Lit l)
+>
+> Con c ts as ->
+> mapUs defAtom2core as `thenUs` \atom_expr_pairs ->
+> returnUs (
+> foldr (\(a,b) -> mkLet a b)
+> (Con c ts (map fst atom_expr_pairs))
> atom_expr_pairs)
->
-> CoPrim op ts as ->
-> mapSUs defAtom2core as `thenSUs` \atom_expr_pairs ->
-> returnSUs (
+>
+> Prim op ts as ->
+> mapUs defAtom2core as `thenUs` \atom_expr_pairs ->
+> returnUs (
> foldr (\(a,b) -> mkLet a b)
-> (CoPrim op ts (map fst atom_expr_pairs))
+> (Prim op ts (map fst atom_expr_pairs))
> atom_expr_pairs)
->
-> CoLam vs e ->
-> d2c e `thenSUs` \e' ->
-> returnSUs (CoLam vs e')
->
-> CoTyLam alpha e ->
-> d2c e `thenSUs` \e' ->
-> returnSUs (CoTyLam alpha e')
->
-> CoApp e v ->
-> d2c e `thenSUs` \e' ->
-> defAtom2core v `thenSUs` \(v',e'') ->
-> returnSUs (mkLet v' e'' (CoApp e' v'))
->
-> CoTyApp e t ->
-> d2c e `thenSUs` \e' ->
-> returnSUs (CoTyApp e' t)
->
-> CoCase e ps ->
-> d2c e `thenSUs` \e' ->
-> defCaseAlts2Core ps `thenSUs` \ps' ->
-> returnSUs (CoCase e' ps')
->
-> CoLet b e ->
-> d2c e `thenSUs` \e' ->
-> defBinding2core b `thenSUs` \b' ->
-> returnSUs (CoLet b' e')
->
-> CoSCC l e ->
-> d2c e `thenSUs` \e' ->
-> returnSUs (CoSCC l e')
+>
+> Lam vs e ->
+> d2c e `thenUs` \e' ->
+> returnUs (Lam vs e')
+>
+> CoTyLam alpha e ->
+> d2c e `thenUs` \e' ->
+> returnUs (CoTyLam alpha e')
+>
+> App e v ->
+> d2c e `thenUs` \e' ->
+> defAtom2core v `thenUs` \(v',e'') ->
+> returnUs (mkLet v' e'' (App e' v'))
+>
+> CoTyApp e t ->
+> d2c e `thenUs` \e' ->
+> returnUs (CoTyApp e' t)
+>
+> Case e ps ->
+> d2c e `thenUs` \e' ->
+> defCaseAlts2Core ps `thenUs` \ps' ->
+> returnUs (Case e' ps')
+>
+> Let b e ->
+> d2c e `thenUs` \e' ->
+> defBinding2core b `thenUs` \b' ->
+> returnUs (Let b' e')
+>
+> SCC l e ->
+> d2c e `thenUs` \e' ->
+> returnUs (SCC l e')
-> defCaseAlts2Core :: DefCaseAlternatives
-> -> SUniqSM PlainCoreCaseAlternatives
->
+> defCaseAlts2Core :: DefCaseAlternatives
+> -> UniqSM CoreCaseAlts
+>
> defCaseAlts2Core alts = case alts of
-> CoAlgAlts alts dflt ->
-> mapSUs algAlt2Core alts `thenSUs` \alts' ->
-> defAlt2Core dflt `thenSUs` \dflt' ->
-> returnSUs (CoAlgAlts alts' dflt')
->
-> CoPrimAlts alts dflt ->
-> mapSUs primAlt2Core alts `thenSUs` \alts' ->
-> defAlt2Core dflt `thenSUs` \dflt' ->
-> returnSUs (CoPrimAlts alts' dflt')
->
+> AlgAlts alts dflt ->
+> mapUs algAlt2Core alts `thenUs` \alts' ->
+> defAlt2Core dflt `thenUs` \dflt' ->
+> returnUs (AlgAlts alts' dflt')
+>
+> PrimAlts alts dflt ->
+> mapUs primAlt2Core alts `thenUs` \alts' ->
+> defAlt2Core dflt `thenUs` \dflt' ->
+> returnUs (PrimAlts alts' dflt')
+>
> where
->
-> algAlt2Core (c, vs, e) = d2c e `thenSUs` \e' -> returnSUs (c, vs, e')
-> primAlt2Core (l, e) = d2c e `thenSUs` \e' -> returnSUs (l, e')
->
-> defAlt2Core CoNoDefault = returnSUs CoNoDefault
-> defAlt2Core (CoBindDefault v e) =
-> d2c e `thenSUs` \e' ->
-> returnSUs (CoBindDefault v e')
+>
+> algAlt2Core (c, vs, e) = d2c e `thenUs` \e' -> returnUs (c, vs, e')
+> primAlt2Core (l, e) = d2c e `thenUs` \e' -> returnUs (l, e')
+>
+> defAlt2Core NoDefault = returnUs NoDefault
+> defAlt2Core (BindDefault v e) =
+> d2c e `thenUs` \e' ->
+> returnUs (BindDefault v e')
-> mkLet :: PlainCoreAtom
-> -> Maybe PlainCoreExpr
-> -> PlainCoreExpr
-> -> PlainCoreExpr
->
-> mkLet (CoVarAtom v) (Just e) e' = CoLet (CoNonRec v e) e'
+> mkLet :: CoreArg
+> -> Maybe CoreExpr
+> -> CoreExpr
+> -> CoreExpr
+>
+> mkLet (VarArg v) (Just e) e' = Let (NonRec v e) e'
> mkLet v Nothing e' = e'
-----------------------------------------------------------------------------
XXX - in here becuase if it goes in DefUtils we've got mutual recursion.
-> defPanic :: String -> String -> DefExpr -> SUniqSM a
+> defPanic :: String -> String -> DefExpr -> UniqSM a
> defPanic modl fun expr =
-> d2c expr `thenSUs` \expr ->
+> d2c expr `thenUs` \expr ->
> panic (modl ++ "(" ++ fun ++ "): " ++ ppShow 80 (ppr PprDebug expr))
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface DefExpr where
-import CmdLineOpts(SwitchResult)
-import CoreSyn(CoreArg, CoreExpr)
-import DefSyn(DefBindee)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tran :: (a -> SwitchResult) -> UniqFM (CoreExpr Id DefBindee) -> UniqFM UniType -> CoreExpr Id DefBindee -> [CoreArg DefBindee] -> SplitUniqSupply -> CoreExpr Id DefBindee
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DefExpr]{Transformation Algorithm for Expressions}
> module DefExpr (
> tran
> ) where
->
+>
> import DefSyn
> import CoreSyn
> import DefUtils
> import TreelessForm
> import Cyclic
-> import AbsUniType ( applyTypeEnvToTy, isPrimType,
-> SigmaType(..), UniType
+> import Type ( applyTypeEnvToTy, isPrimType,
+> SigmaType(..), Type
> IF_ATTACK_PRAGMAS(COMMA cmpUniType)
> )
> import CmdLineOpts ( SwitchResult, switchIsOn )
-> import CoreFuns ( mkCoLam, unTagBinders, typeOfCoreExpr )
+> import CoreUnfold ( UnfoldingDetails(..) )
+> import CoreUtils ( mkValLam, unTagBinders, coreExprType )
> import Id ( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
> isInstId_maybe
> )
> import Inst -- Inst(..)
-> import IdEnv
> import IdInfo
> import Maybes ( Maybe(..) )
> import Outputable
-> import SimplEnv ( SwitchChecker(..), UnfoldingDetails(..) )
-> import SplitUniq
-> import TyVarEnv
+> import UniqSupply
> import Util
> -- tmp
> -> TypeEnv -- Type environment
> -> DefExpr -- input expression
> -> [DefCoreArg] -- args
-> -> SUniqSM DefExpr
+> -> UniqSM DefExpr
-> tran sw p t e@(CoVar (DefArgVar id)) as =
+> tran sw p t e@(Var (DefArgVar id)) as =
> tranVar sw p id
> (
-> mapArgs (\e -> tran sw p t e []) as `thenSUs` \as ->
-> returnSUs (applyToArgs (CoVar (DefArgVar new_id)) as)
+> mapArgs (\e -> tran sw p t e []) as `thenUs` \as ->
+> returnUs (mkGenApp (Var (DefArgVar new_id)) as)
> )
> (
-> \e ->
-> tran sw p t e as `thenSUs` \e ->
-> returnSUs (mkLabel (applyToArgs (CoVar (DefArgVar new_id))
-> (map (substTyArg t) as))
+> \e ->
+> tran sw p t e as `thenUs` \e ->
+> returnUs (mkLabel (mkGenApp (Var (DefArgVar new_id))
+> (map (substTyArg t) as))
> e)
> )
> where new_id = applyTypeEnvToId t id
-> tran sw p t e@(CoLit l) [] =
-> returnSUs e
->
-> tran sw p t (CoCon c ts es) [] =
-> mapSUs (tranAtom sw p t) es `thenSUs` \es ->
-> returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es)
->
-> tran sw p t (CoPrim op ts es) [] = -- XXX constant folding?
-> mapSUs (tranAtom sw p t) es `thenSUs` \es ->
-> returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es)
->
-> tran sw p t (CoLam vs e) [] =
-> tran sw p t e [] `thenSUs` \e ->
-> returnSUs (mkCoLam (map (applyTypeEnvToId t) vs) e)
->
-> tran sw p t (CoLam vs e) as =
-> subst s e `thenSUs` \e ->
-> tran sw p t (mkCoLam rvs e) ras
+> tran sw p t e@(Lit l) [] =
+> returnUs e
+>
+> tran sw p t (Con c ts es) [] =
+> mapUs (tranAtom sw p t) es `thenUs` \es ->
+> returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
+>
+> tran sw p t (Prim op ts es) [] = -- XXX constant folding?
+> mapUs (tranAtom sw p t) es `thenUs` \es ->
+> returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
+>
+> tran sw p t (Lam vs e) [] =
+> tran sw p t e [] `thenUs` \e ->
+> returnUs (mkValLam (map (applyTypeEnvToId t) vs) e)
+>
+> tran sw p t (Lam vs e) as =
+> subst s e `thenUs` \e ->
+> tran sw p t (mkValLam rvs e) ras
> where
> (rvs,ras,s) = mkSubst vs as []
> tran sw p t (CoTyLam alpha e) [] =
-> tran sw p t e [] `thenSUs` \e ->
-> returnSUs (CoTyLam alpha e)
+> tran sw p t e [] `thenUs` \e ->
+> returnUs (CoTyLam alpha e)
>
ToDo: use the environment rather than doing explicit substitution
> tran sw p t (CoTyLam alpha e) (TypeArg ty : as) =
> tran sw p t (applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e) as
-> tran sw p t (CoApp e v) as =
-> maybeJumbleApp e v `thenSUs` \j ->
+> tran sw p t (App e v) as =
+> maybeJumbleApp e v `thenUs` \j ->
> case j of
> Nothing -> tran sw p t e (ValArg v : as)
> Just e' -> tran sw p t e' as
> tran sw p t (CoTyApp e ty) as =
> tran sw p t e (TypeArg (applyTypeEnvToTy t ty) : as)
>
-> tran sw p t (CoLet (CoNonRec v e) e') as =
-> tran sw p t e [] `thenSUs` \e ->
+> tran sw p t (Let (NonRec v e) e') as =
+> tran sw p t e [] `thenUs` \e ->
> if isConstant e then
> trace "yippee!!" $
-> subst [(v,removeLabels e)] e' `thenSUs` \e' ->
+> subst [(v,removeLabels e)] e' `thenUs` \e' ->
> tran sw p t e' as
> else
-> tran sw p t e' as `thenSUs` \e' ->
-> returnSUs (CoLet (CoNonRec (applyTypeEnvToId t v) e) e')
->
-> tran sw p t (CoLet (CoRec bs) e) as =
-> tranRecBinds sw p t bs e `thenSUs` \(p',resid,e) ->
-> tran sw p' t e as `thenSUs` \e ->
-> returnSUs (mkDefLetrec resid e)
->
-> tran sw p t (CoSCC l e) as =
-> tran sw p t e [] `thenSUs` \e ->
-> mapArgs (\e -> tran sw p t e []) as `thenSUs` \as ->
-> returnSUs (applyToArgs (CoSCC l e) as)
->
-> tran sw p t (CoCase e ps) as =
+> tran sw p t e' as `thenUs` \e' ->
+> returnUs (Let (NonRec (applyTypeEnvToId t v) e) e')
+>
+> tran sw p t (Let (Rec bs) e) as =
+> tranRecBinds sw p t bs e `thenUs` \(p',resid,e) ->
+> tran sw p' t e as `thenUs` \e ->
+> returnUs (mkDefLetrec resid e)
+>
+> tran sw p t (SCC l e) as =
+> tran sw p t e [] `thenUs` \e ->
+> mapArgs (\e -> tran sw p t e []) as `thenUs` \as ->
+> returnUs (mkGenApp (SCC l e) as)
+>
+> tran sw p t (Case e ps) as =
> tranCase sw p t e [] ps as
->
-> tran _ _ _ e as =
-> defPanic "DefExpr" "tran" (applyToArgs e as)
+>
+> tran _ _ _ e as =
+> defPanic "DefExpr" "tran" (mkGenApp e as)
-----------------------------------------------------------------------------
Transformation for case expressions of the form (case e1..en of {..})
> -> [DefCoreArg]
> -> DefCaseAlternatives
> -> [DefCoreArg]
-> -> SUniqSM DefExpr
+> -> UniqSM DefExpr
> tranCase sw p t e bs ps as = case e of
->
-> CoVar (DefArgVar id) ->
+>
+> Var (DefArgVar id) ->
> tranVar sw p id
> (
-> tranAlts sw p t ps as `thenSUs` \ps ->
-> mapArgs (\e -> tran sw p t e []) bs `thenSUs` \bs ->
-> returnSUs
-> (CoCase
-> (applyToArgs (CoVar (DefArgVar
-> (applyTypeEnvToId t id)))
+> tranAlts sw p t ps as `thenUs` \ps ->
+> mapArgs (\e -> tran sw p t e []) bs `thenUs` \bs ->
+> returnUs
+> (Case
+> (mkGenApp (Var (DefArgVar
+> (applyTypeEnvToId t id)))
> bs)
> ps)
> )
> (
> \e ->
-> tranCase sw p t e bs ps as `thenSUs` \e ->
-> returnSUs
-> (mkLabel
-> (applyToArgs
-> (CoCase (applyToArgs (CoVar (DefArgVar id))
+> tranCase sw p t e bs ps as `thenUs` \e ->
+> returnUs
+> (mkLabel
+> (mkGenApp
+> (Case (mkGenApp (Var (DefArgVar id))
> (map (substTyArg t) bs))
> ps)
> (map (substTyArg t) as))
> e)
> )
>
-> CoLit l ->
+> Lit l ->
> case bs of
-> [] -> tranAlts sw p t ps as `thenSUs` \ps ->
-> returnSUs (CoCase e ps)
+> [] -> tranAlts sw p t ps as `thenUs` \ps ->
+> returnUs (Case e ps)
> _ -> die_horribly
->
-> CoPrim op ts es ->
+>
+> Prim op ts es ->
> case bs of
-> [] -> tranAlts sw p t ps as `thenSUs` \ps ->
-> mapSUs (tranAtom sw p t) es `thenSUs` \es ->
-> returnSUs (CoCase (CoPrim op
+> [] -> tranAlts sw p t ps as `thenUs` \ps ->
+> mapUs (tranAtom sw p t) es `thenUs` \es ->
+> returnUs (Case (Prim op
> (map (applyTypeEnvToTy t) ts) es) ps)
> _ -> die_horribly
->
-> CoCon c ts es ->
+>
+> Con c ts es ->
> case bs of
> [] -> case ps of
-> CoAlgAlts alts def ->
+> AlgAlts alts def ->
> reduceCase sw p c ts es alts def as
-> CoPrimAlts alts def -> die_horribly
+> PrimAlts alts def -> die_horribly
> _ -> die_horribly
->
-> CoLam vs e ->
+>
+> Lam vs e ->
> case bs of
> [] -> die_horribly
> (TypeArg _ : _) -> die_horribly
-> _ -> subst s e `thenSUs` \e ->
+> _ -> subst s e `thenUs` \e ->
> tranCase sw p t e rbs ps as
> where
> (rvs,rbs,s) = mkSubst vs bs []
> TypeArg ty : bs' -> tranCase sw p t e' bs' ps as
> where e' = applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e
> _ -> die_horribly
->
-> CoApp e v ->
-> maybeJumbleApp e v `thenSUs` \j ->
+>
+> App e v ->
+> maybeJumbleApp e v `thenUs` \j ->
> case j of
> Nothing -> tranCase sw p t e (ValArg v : bs) ps as
> Just e' -> tranCase sw p t e' bs ps as
->
+>
> CoTyApp e ty ->
> tranCase sw p t e (TypeArg (applyTypeEnvToTy t ty) : bs)
> ps as
->
-> CoLet (CoNonRec v e) e' ->
-> tran sw p t e [] `thenSUs` \e ->
+>
+> Let (NonRec v e) e' ->
+> tran sw p t e [] `thenUs` \e ->
> if isConstant e then
> trace "yippee2!!" $
-> subst [(v,removeLabels e)] e' `thenSUs` \e' ->
+> subst [(v,removeLabels e)] e' `thenUs` \e' ->
> tranCase sw p t e' bs ps as
> else
-> tranCase sw p t e' bs ps as `thenSUs` \e' ->
-> returnSUs (CoLet (CoNonRec
+> tranCase sw p t e' bs ps as `thenUs` \e' ->
+> returnUs (Let (NonRec
> (applyTypeEnvToId t v) e) e')
>
-> CoLet (CoRec binds) e ->
-> tranRecBinds sw p t binds e `thenSUs` \(p',resid,e) ->
-> tranCase sw p' t e bs ps as `thenSUs` \e ->
-> returnSUs (mkDefLetrec resid e)
->
+> Let (Rec binds) e ->
+> tranRecBinds sw p t binds e `thenUs` \(p',resid,e) ->
+> tranCase sw p' t e bs ps as `thenUs` \e ->
+> returnUs (mkDefLetrec resid e)
+>
> -- ToDo: sort out cost centres. Currently they act as a barrier
> -- to optimisation.
-> CoSCC l e ->
-> tran sw p t e [] `thenSUs` \e ->
+> SCC l e ->
+> tran sw p t e [] `thenUs` \e ->
> mapArgs (\e -> tran sw p t e []) bs
-> `thenSUs` \bs ->
-> tranAlts sw p t ps as `thenSUs` \ps ->
-> returnSUs (CoCase (applyToArgs (CoSCC l e) bs)
+> `thenUs` \bs ->
+> tranAlts sw p t ps as `thenUs` \ps ->
+> returnUs (Case (mkGenApp (SCC l e) bs)
> ps)
->
-> CoCase e ps' ->
+>
+> Case e ps' ->
> tranCase sw p t e []
-> (mapAlts (\e -> applyToArgs (CoCase e ps) bs) ps') as
->
+> (mapAlts (\e -> mkGenApp (Case e ps) bs) ps') as
+>
> _ -> die_horribly
->
-> where die_horribly = defPanic "DefExpr" "tranCase"
-> (applyToArgs (CoCase (applyToArgs e bs) ps) as)
+>
+> where die_horribly = defPanic "DefExpr" "tranCase"
+> (mkGenApp (Case (mkGenApp e bs) ps) as)
-----------------------------------------------------------------------------
-Deciding whether or not to replace a function variable with it's
+Deciding whether or not to replace a function variable with it's
definition. The tranVar function is passed four arguments: the
environment, the Id itself, the expression to return if no
unfolding takes place, and a function to apply to the unfolded expression
should an unfolding be required.
-> tranVar
+> tranVar
> :: SwitchChecker who_knows
> -> IdEnv DefExpr
> -> Id
-> -> SUniqSM DefExpr
-> -> (DefExpr -> SUniqSM DefExpr)
-> -> SUniqSM DefExpr
->
+> -> UniqSM DefExpr
+> -> (DefExpr -> UniqSM DefExpr)
+> -> UniqSM DefExpr
+>
> tranVar sw p id no_unfold unfold_with =
->
+>
> case lookupIdEnv p id of
> Just e' ->
-> rebindExpr e' `thenSUs` \e' ->
-> if deforestable id
+> rebindExpr e' `thenUs` \e' ->
+> if deforestable id
> then unfold_with e'
> else panic "DefExpr(tran): not deforestable id in env"
in which case it will have an unfolding inside the Id
itself.
-> Nothing ->
+> Nothing ->
> if (not . deforestable) id
> then no_unfold
->
+>
> else case (getIdUnfolding id) of
-> GeneralForm _ _ expr guidance ->
-> panic "DefExpr:GeneralForm has changed a little; needs mod here"
+> GenForm _ _ expr guidance ->
+> panic "DefExpr:GenForm has changed a little; needs mod here"
> -- SLPJ March 95
>
>--??? -- ToDo: too much overhead here.
>--??? let e' = c2d nullIdEnv expr in
->--??? convertToTreelessForm sw e' `thenSUs` \e'' ->
+>--??? convertToTreelessForm sw e' `thenUs` \e'' ->
>--??? unfold_with e''
> _ -> no_unfold
> {- panic
> ("DefExpr(tran): Deforestable id `"
-> ++ ppShow 80 (ppr PprDebug id)
+> ++ ppShow 80 (ppr PprDebug id)
> ++ "' doesn't have an unfolding.") -}
-----------------------------------------------------------------------------
Transform a set of case alternatives.
-> tranAlts
+> tranAlts
> :: SwitchChecker who_knows
> -> IdEnv DefExpr
> -> TypeEnv
> -> DefCaseAlternatives
> -> [DefCoreArg]
-> -> SUniqSM DefCaseAlternatives
+> -> UniqSM DefCaseAlternatives
-> tranAlts sw p t (CoAlgAlts alts def) as =
-> mapSUs (tranAlgAlt sw p t as) alts `thenSUs` \alts ->
-> tranDefault sw p t def as `thenSUs` \def ->
-> returnSUs (CoAlgAlts alts def)
-> tranAlts sw p t (CoPrimAlts alts def) as =
-> mapSUs (tranPrimAlt sw p t as) alts `thenSUs` \alts ->
-> tranDefault sw p t def as `thenSUs` \def ->
-> returnSUs (CoPrimAlts alts def)
+> tranAlts sw p t (AlgAlts alts def) as =
+> mapUs (tranAlgAlt sw p t as) alts `thenUs` \alts ->
+> tranDefault sw p t def as `thenUs` \def ->
+> returnUs (AlgAlts alts def)
+> tranAlts sw p t (PrimAlts alts def) as =
+> mapUs (tranPrimAlt sw p t as) alts `thenUs` \alts ->
+> tranDefault sw p t def as `thenUs` \def ->
+> returnUs (PrimAlts alts def)
> tranAlgAlt sw p t as (c, vs, e) =
-> tran sw p t e as `thenSUs` \e ->
-> returnSUs (c, map (applyTypeEnvToId t) vs, e)
+> tran sw p t e as `thenUs` \e ->
+> returnUs (c, map (applyTypeEnvToId t) vs, e)
> tranPrimAlt sw p t as (l, e) =
-> tran sw p t e as `thenSUs` \e ->
-> returnSUs (l, e)
->
-> tranDefault sw p t CoNoDefault as = returnSUs CoNoDefault
-> tranDefault sw p t (CoBindDefault v e) as =
-> tran sw p t e as `thenSUs` \e ->
-> returnSUs (CoBindDefault (applyTypeEnvToId t v) e)
+> tran sw p t e as `thenUs` \e ->
+> returnUs (l, e)
+>
+> tranDefault sw p t NoDefault as = returnUs NoDefault
+> tranDefault sw p t (BindDefault v e) as =
+> tran sw p t e as `thenUs` \e ->
+> returnUs (BindDefault (applyTypeEnvToId t v) e)
-----------------------------------------------------------------------------
Transform an atom.
-> tranAtom
+> tranAtom
> :: SwitchChecker who_knows
-> -> IdEnv DefExpr
-> -> TypeEnv
-> -> DefAtom
-> -> SUniqSM DefAtom
+> -> IdEnv DefExpr
+> -> TypeEnv
+> -> DefAtom
+> -> UniqSM DefAtom
-> tranAtom sw p t (CoVarAtom v) =
-> tranArg sw p t v `thenSUs` \v ->
-> returnSUs (CoVarAtom v)
-> tranAtom sw p t e@(CoLitAtom l) = -- XXX
-> returnSUs e
+> tranAtom sw p t (VarArg v) =
+> tranArg sw p t v `thenUs` \v ->
+> returnUs (VarArg v)
+> tranAtom sw p t e@(LitArg l) = -- XXX
+> returnUs e
> tranArg sw p t (DefArgExpr e) =
-> tran sw p t e [] `thenSUs` \e ->
-> returnSUs (DefArgExpr e)
+> tran sw p t e [] `thenUs` \e ->
+> returnUs (DefArgExpr e)
> tranArg sw p t e@(Label _ _) =
-> defPanic "DefExpr" "tranArg" (CoVar e)
+> defPanic "DefExpr" "tranArg" (Var e)
> tranArg sw p t (DefArgVar v) =
-> tran sw p t (CoVar (DefArgVar v)) [] `thenSUs` \e ->
-> returnSUs (DefArgExpr e) -- XXX remove this case
+> tran sw p t (Var (DefArgVar v)) [] `thenUs` \e ->
+> returnUs (DefArgExpr e) -- XXX remove this case
-----------------------------------------------------------------------------
Translating recursive definition groups.
and substitute the new function calls throughout the function set.
-> let
+> let
> (unfold,resid) = partition (deforestable . fst) bs
> in
-> mapSUs (tranRecBind sw p t) unfold `thenSUs` \unfold ->
-> mapSUs (tranRecBind sw p t) resid `thenSUs` \resid ->
+> mapUs (tranRecBind sw p t) unfold `thenUs` \unfold ->
+> mapUs (tranRecBind sw p t) resid `thenUs` \resid ->
- Tie knots in the deforestable right-hand sides, and convert the
- results to treeless form. Then extract any nested deforestable
- recursive functions, and place everything we've got in the new
+ Tie knots in the deforestable right-hand sides, and convert the
+ results to treeless form. Then extract any nested deforestable
+ recursive functions, and place everything we've got in the new
environment.
> let (vs,es) = unzip unfold in
-> mapSUs mkLoops es `thenSUs` \res ->
-> let
+> mapUs mkLoops es `thenUs` \res ->
+> let
> (extracted,new_rhss) = unzip res
> new_binds = zip vs new_rhss ++ concat extracted
> in
bound in this letrec are about to change status from not
unfolded to unfolded).
-> mapSUs (\(v,e) ->
-> convertToTreelessForm sw e `thenSUs` \e ->
-> returnSUs (v,e)) new_binds `thenSUs` \fs ->
+> mapUs (\(v,e) ->
+> convertToTreelessForm sw e `thenUs` \e ->
+> returnUs (v,e)) new_binds `thenUs` \fs ->
Now find the total set of free variables of this function set.
> stuff = [ fixupFreeVars fvs id e | (id,e) <- fs ]
> fs' = map fst stuff
> s = concat (map snd stuff)
-> subIt (id,e) = subst s e `thenSUs` \e -> returnSUs (id,e)
+> subIt (id,e) = subst s e `thenUs` \e -> returnUs (id,e)
> in
-> subst s e `thenSUs` \e ->
-> mapSUs subIt resid `thenSUs` \resid ->
-> mapSUs subIt fs' `thenSUs` \fs ->
+> subst s e `thenUs` \e ->
+> mapUs subIt resid `thenUs` \resid ->
+> mapUs subIt fs' `thenUs` \fs ->
-> let res = returnSUs (growIdEnvList p fs, resid, e) in
+> let res = returnUs (growIdEnvList p fs, resid, e) in
> case unzip fs of
-> (evs,ees) -> mapSUs d2c ees `thenSUs` \ees ->
+> (evs,ees) -> mapUs d2c ees `thenUs` \ees ->
> let (vs',es') = unzip bs in
-> mapSUs d2c es' `thenSUs` \es' ->
-> trace ("extraction "
-> ++ showIds (map fst bs)
+> mapUs d2c es' `thenUs` \es' ->
+> trace ("extraction "
+> ++ showIds (map fst bs)
> ++ showIds evs
> ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n"
> ++ "{ result:\n" ++ (concat (map showBind (zip evs ees))) ++ "}\n") res
> where showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
> tranRecBind sw p t (id,e) =
-> tran sw p t e [] `thenSUs` \e ->
-> returnSUs (applyTypeEnvToId t id,e)
+> tran sw p t e [] `thenUs` \e ->
+> returnUs (applyTypeEnvToId t id,e)
> showIds :: [Id] -> String
-> showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids)
+> showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids)
> ++ " )"
-----------------------------------------------------------------------------
-> reduceCase sw p c ts es alts def as =
+> reduceCase sw p c ts es alts def as =
> case [ a | a@(c',vs,e) <- alts, c' == c ] of
> [(c,vs,e)] ->
-> subst (zip vs (map atom2expr es)) e `thenSUs` \e ->
+> subst (zip vs (map atom2expr es)) e `thenUs` \e ->
> tran sw p nullTyVarEnv e as
> [] -> case def of
-> CoNoDefault ->
+> NoDefault ->
> panic "DefExpr(reduceCase): no match"
-> CoBindDefault v e ->
-> subst [(v,CoCon c ts es)] e `thenSUs` \e ->
+> BindDefault v e ->
+> subst [(v,Con c ts es)] e `thenUs` \e ->
> tran sw p nullTyVarEnv e as
> _ -> panic "DefExpr(reduceCase): multiple matches"
-----------------------------------------------------------------------------
Type Substitutions.
-> applyTypeEnvToExpr
+> applyTypeEnvToExpr
> :: TypeEnv
> -> DefExpr
> -> DefExpr
> applyTypeEnvToExpr p e = substTy e
-> where
+> where
> substTy e' = case e' of
-> CoVar (DefArgExpr e) -> panic "DefExpr(substTy): CoVar (DefArgExpr _)"
-> CoVar (Label l e) -> panic "DefExpr(substTy): CoVar (Label _ _)"
-> CoVar (DefArgVar id) -> CoVar (DefArgVar (applyTypeEnvToId p id))
-> CoLit l -> e'
-> CoCon c ts es ->
-> CoCon c (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
-> CoPrim op ts es ->
-> CoPrim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
-> CoLam vs e -> CoLam (map (applyTypeEnvToId p) vs) (substTy e)
+> Var (DefArgExpr e) -> panic "DefExpr(substTy): Var (DefArgExpr _)"
+> Var (Label l e) -> panic "DefExpr(substTy): Var (Label _ _)"
+> Var (DefArgVar id) -> Var (DefArgVar (applyTypeEnvToId p id))
+> Lit l -> e'
+> Con c ts es ->
+> Con c (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
+> Prim op ts es ->
+> Prim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
+> Lam vs e -> Lam (map (applyTypeEnvToId p) vs) (substTy e)
> CoTyLam alpha e -> CoTyLam alpha (substTy e)
-> CoApp e v -> CoApp (substTy e) (substTyAtom v)
-> CoTyApp e t -> mkCoTyApp (substTy e) (applyTypeEnvToTy p t)
-> CoCase e ps -> CoCase (substTy e) (substTyCaseAlts ps)
-> CoLet (CoNonRec id e) e' ->
-> CoLet (CoNonRec (applyTypeEnvToId p id) (substTy e))
+> App e v -> App (substTy e) (substTyAtom v)
+> CoTyApp e t -> CoTyApp (substTy e) (applyTypeEnvToTy p t)
+> Case e ps -> Case (substTy e) (substTyCaseAlts ps)
+> Let (NonRec id e) e' ->
+> Let (NonRec (applyTypeEnvToId p id) (substTy e))
> (substTy e')
-> CoLet (CoRec bs) e ->
-> CoLet (CoRec (map substTyRecBind bs)) (substTy e)
+> Let (Rec bs) e ->
+> Let (Rec (map substTyRecBind bs)) (substTy e)
> where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e)
-> CoSCC l e -> CoSCC l (substTy e)
+> SCC l e -> SCC l (substTy e)
> substTyAtom :: DefAtom -> DefAtom
-> substTyAtom (CoVarAtom v) = CoVarAtom (substTyArg v)
-> substTyAtom (CoLitAtom l) = CoLitAtom l -- XXX
+> substTyAtom (VarArg v) = VarArg (substTyArg v)
+> substTyAtom (LitArg l) = LitArg l -- XXX
> substTyArg :: DefBindee -> DefBindee
> substTyArg (DefArgExpr e) = DefArgExpr (substTy e)
> substTyArg e@(DefArgVar id) = -- XXX
> DefArgVar (applyTypeEnvToId p id)
-> substTyCaseAlts (CoAlgAlts as def)
-> = CoAlgAlts (map substTyAlgAlt as) (substTyDefault def)
-> substTyCaseAlts (CoPrimAlts as def)
-> = CoPrimAlts (map substTyPrimAlt as) (substTyDefault def)
+> substTyCaseAlts (AlgAlts as def)
+> = AlgAlts (map substTyAlgAlt as) (substTyDefault def)
+> substTyCaseAlts (PrimAlts as def)
+> = PrimAlts (map substTyPrimAlt as) (substTyDefault def)
> substTyAlgAlt (c, vs, e) = (c, map (applyTypeEnvToId p) vs, substTy e)
> substTyPrimAlt (l, e) = (l, substTy e)
-> substTyDefault CoNoDefault = CoNoDefault
-> substTyDefault (CoBindDefault id e) =
-> CoBindDefault (applyTypeEnvToId p id) (substTy e)
+> substTyDefault NoDefault = NoDefault
+> substTyDefault (BindDefault id e) =
+> BindDefault (applyTypeEnvToId p id) (substTy e)
-> substTyArg t (ValArg e) =
-> ValArg (CoVarAtom (DefArgExpr (applyTypeEnvToExpr t (atom2expr e))))
+> substTyArg t (ValArg e) =
+> ValArg (VarArg (DefArgExpr (applyTypeEnvToExpr t (atom2expr e))))
> substTyArg t (TypeArg ty) = TypeArg ty
-----------------------------------------------------------------------------
> mapAlts f ps = case ps of
-> CoAlgAlts alts def ->
-> CoAlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def)
-> CoPrimAlts alts def ->
-> CoPrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def)
->
-> mapDef f CoNoDefault = CoNoDefault
-> mapDef f (CoBindDefault v e) = CoBindDefault v (f e)
+> AlgAlts alts def ->
+> AlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def)
+> PrimAlts alts def ->
+> PrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def)
+>
+> mapDef f NoDefault = NoDefault
+> mapDef f (BindDefault v e) = BindDefault v (f e)
-----------------------------------------------------------------------------
Apply a function to all the ValArgs in an Args list.
-> mapArgs
-> :: (DefExpr -> SUniqSM DefExpr)
-> -> [DefCoreArg]
-> -> SUniqSM [DefCoreArg]
->
-> mapArgs f [] =
-> returnSUs []
-> mapArgs f (a@(TypeArg ty) : as) =
-> mapArgs f as `thenSUs` \as ->
-> returnSUs (a:as)
+> mapArgs
+> :: (DefExpr -> UniqSM DefExpr)
+> -> [DefCoreArg]
+> -> UniqSM [DefCoreArg]
+>
+> mapArgs f [] =
+> returnUs []
+> mapArgs f (a@(TypeArg ty) : as) =
+> mapArgs f as `thenUs` \as ->
+> returnUs (a:as)
> mapArgs f (ValArg v : as) =
-> f (atom2expr v) `thenSUs` \e ->
-> mapArgs f as `thenSUs` \as ->
-> returnSUs (ValArg (CoVarAtom (DefArgExpr e)) : as)
->
+> f (atom2expr v) `thenUs` \e ->
+> mapArgs f as `thenUs` \as ->
+> returnUs (ValArg (VarArg (DefArgExpr e)) : as)
+>
> mkSubst [] as s = ([],as,s)
> mkSubst vs [] s = (vs,[],s)
We also pull out lets from function arguments, and primitive case
expressions (which can't fail anyway).
-Think:
+Think:
(t (case u of x -> v))
====>
ToDo: sort this mess out - could be more efficient.
-> maybeJumbleApp :: DefExpr -> DefAtom -> SUniqSM (Maybe DefExpr)
-> maybeJumbleApp e (CoLitAtom _) = returnSUs Nothing -- ToDo remove
-> maybeJumbleApp e (CoVarAtom (DefArgExpr (CoVar (DefArgVar _))))
-> = returnSUs Nothing
-> maybeJumbleApp e (CoVarAtom (DefArgExpr t))
+> maybeJumbleApp :: DefExpr -> DefAtom -> UniqSM (Maybe DefExpr)
+> maybeJumbleApp e (LitArg _) = returnUs Nothing -- ToDo remove
+> maybeJumbleApp e (VarArg (DefArgExpr (Var (DefArgVar _))))
+> = returnUs Nothing
+> maybeJumbleApp e (VarArg (DefArgExpr t))
> = let t' = pull_out t [] in
> case t' of
-> CoLet _ _ -> returnSUs (Just t')
-> CoCase (CoPrim _ _ _) (CoPrimAlts [] _) -> returnSUs (Just t')
+> Let _ _ -> returnUs (Just t')
+> Case (Prim _ _ _) (PrimAlts [] _) -> returnUs (Just t')
> _ -> if isBoringExpr t then
> rebind_with_let t
> else
-> returnSUs Nothing
+> returnUs Nothing
-> where isBoringExpr (CoVar (DefArgVar z)) = (not . deforestable) z
-> isBoringExpr (CoPrim op ts es) = True
-> isBoringExpr (CoCase e ps) = isBoringExpr e
+> where isBoringExpr (Var (DefArgVar z)) = (not . deforestable) z
+> isBoringExpr (Prim op ts es) = True
+> isBoringExpr (Case e ps) = isBoringExpr e
> && boringCaseAlternatives ps
-> isBoringExpr (CoApp l r) = isBoringExpr l
+> isBoringExpr (App l r) = isBoringExpr l
> isBoringExpr (CoTyApp l t) = isBoringExpr l
> isBoringExpr _ = False
>
-> boringCaseAlternatives (CoAlgAlts as d) =
+> boringCaseAlternatives (AlgAlts as d) =
> all boringAlgAlt as && boringDefault d
-> boringCaseAlternatives (CoPrimAlts as d) =
+> boringCaseAlternatives (PrimAlts as d) =
> all boringPrimAlt as && boringDefault d
->
+>
> boringAlgAlt (c,xs,e) = isBoringExpr e
> boringPrimAlt (l,e) = isBoringExpr e
->
-> boringDefault CoNoDefault = True
-> boringDefault (CoBindDefault x e) = isBoringExpr e
-
-> pull_out (CoLet b t) as = CoLet b (pull_out t as)
-> pull_out (CoApp l r) as = pull_out l (r:as)
-> pull_out (CoCase prim@(CoPrim _ _ _)
-> (CoPrimAlts [] (CoBindDefault x u))) as
-> = CoCase prim (CoPrimAlts [] (CoBindDefault x
+>
+> boringDefault NoDefault = True
+> boringDefault (BindDefault x e) = isBoringExpr e
+
+> pull_out (Let b t) as = Let b (pull_out t as)
+> pull_out (App l r) as = pull_out l (r:as)
+> pull_out (Case prim@(Prim _ _ _)
+> (PrimAlts [] (BindDefault x u))) as
+> = Case prim (PrimAlts [] (BindDefault x
> (pull_out u as)))
-> pull_out t as
-> = CoApp e (CoVarAtom (DefArgExpr (foldl CoApp t as)))
->
-> rebind_with_let t =
-> d2c t `thenSUs` \core_t ->
-> newDefId (typeOfCoreExpr core_t) `thenSUs` \x ->
+> pull_out t as
+> = App e (VarArg (DefArgExpr (foldl App t as)))
+>
+> rebind_with_let t =
+> d2c t `thenUs` \core_t ->
+> newDefId (coreExprType core_t) `thenUs` \x ->
> trace "boring epxr found!" $
-> returnSUs (Just (CoLet (CoNonRec x t)
-> (CoApp e (CoVarAtom (
-> DefArgExpr (CoVar (
+> returnUs (Just (Let (NonRec x t)
+> (App e (VarArg (
+> DefArgExpr (Var (
> DefArgVar x)))))))
-----------------------------------------------------------------------------
> Just (LitInst _ _ _ _) -> True
> _ -> False
-> isConstant (CoCon c [] []) = True
-> isConstant (CoLit l) = True
-> isConstant (CoVar (Label l e)) = isConstant e
+> isConstant (Con c [] []) = True
+> isConstant (Lit l) = True
+> isConstant (Var (Label l e)) = isConstant e
> isConstant _ = False
-> removeLabels (CoVar (Label l e)) = removeLabels e
+> removeLabels (Var (Label l e)) = removeLabels e
> removeLabels e = e
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface DefSyn where
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr)
-import Id(Id)
-type DefAtom = CoreAtom DefBindee
-data DefBindee = DefArgExpr (CoreExpr Id DefBindee) | DefArgVar Id | Label (CoreExpr Id DefBindee) (CoreExpr Id DefBindee)
-type DefBinding = CoreBinding Id DefBindee
-type DefCaseAlternatives = CoreCaseAlternatives Id DefBindee
-type DefCaseDefault = CoreCaseDefault Id DefBindee
-type DefCoreArg = CoreArg DefBindee
-type DefExpr = CoreExpr Id DefBindee
-type DefProgram = [CoreBinding Id DefBindee]
-mkLabel :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee -> CoreExpr Id DefBindee
-
This is exactly the same as core, except that the argument to
application can be an arbitrary expression.
-> type DefProgram = [CoreBinding Id DefBindee]
-> type DefBinding = CoreBinding Id DefBindee
-> type DefExpr = CoreExpr Id DefBindee
-> type DefAtom = CoreAtom DefBindee
-> type DefCaseAlternatives = CoreCaseAlternatives Id DefBindee
-> type DefCaseDefault = CoreCaseDefault Id DefBindee
+> type DefProgram = [GenCoreBinding Id DefBindee]
+> type DefBinding = GenCoreBinding Id DefBindee
+> type DefExpr = GenCoreExpr Id DefBindee
+> type DefAtom = GenCoreAtom DefBindee
+> type DefCaseAlternatives = GenCoreCaseAlts Id DefBindee
+> type DefCaseDefault = GenCoreCaseDefault Id DefBindee
-> type DefCoreArg = CoreArg DefBindee
+> type DefCoreArg = GenCoreArg DefBindee
-> data DefBindee
+> data DefBindee
> = DefArgExpr DefExpr -- arbitrary expressions as argumemts
> | DefArgVar Id -- or just ids
> | Label DefExpr DefExpr -- labels for detecting cycles
following are alternative representations for certain expressions.
The forms on the left are disallowed:
-CoVar (DefArgExpr e) == e
-CoVarAtom (Label l e) == CoVarAtom (DefArgExpr (CoVar (Label l e)))
+Var (DefArgExpr e) == e
+VarArg (Label l e) == VarArg (DefArgExpr (Var (Label l e)))
For completeness, we should also have:
-CoVarAtom (DefArgVar v) == CoVarAtom (DefArgExpr (CoVar (DefArgVar v)))
-CoLitAtom l == CoVarAtom (DefArgExpr (CoLit l))
+VarArg (DefArgVar v) == VarArg (DefArgExpr (Var (DefArgVar v)))
+LitArg l == VarArg (DefArgExpr (Lit l))
-In other words, atoms must all be of the form (CoVarAtom (DefArgExpr
-_)) and the argument to a CoVar can only be Label or DefArgVar.
+In other words, atoms must all be of the form (VarArg (DefArgExpr
+_)) and the argument to a Var can only be Label or DefArgVar.
> mkLabel :: DefExpr -> DefExpr -> DefExpr
-> mkLabel l e = CoVar (Label l e)
+> mkLabel l e = Var (Label l e)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface DefUtils where
-import CoreSyn(CoreAtom, CoreCaseAlternatives, CoreExpr)
-import DefSyn(DefBindee)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-data RenameResult = NotRenaming | IsRenaming [(Id, Id)] | InconsistentRenaming [(Id, Id)]
-atom2expr :: CoreAtom DefBindee -> CoreExpr Id DefBindee
-consistent :: [(Id, Id)] -> Bool
-deforestable :: Id -> Bool
-foldrSUs :: (a -> b -> SplitUniqSupply -> b) -> b -> [a] -> SplitUniqSupply -> b
-freeTyVars :: CoreExpr Id DefBindee -> [TyVar]
-freeVars :: CoreExpr Id DefBindee -> [Id]
-isArgId :: Id -> Bool
-mkDefLetrec :: [(a, CoreExpr a b)] -> CoreExpr a b -> CoreExpr a b
-newDefId :: UniType -> SplitUniqSupply -> Id
-newTmpId :: UniType -> SplitUniqSupply -> Id
-rebindExpr :: CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee
-renameExprs :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee -> SplitUniqSupply -> RenameResult
-strip :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee
-stripAtom :: CoreAtom DefBindee -> CoreAtom DefBindee
-stripCaseAlts :: CoreCaseAlternatives Id DefBindee -> CoreCaseAlternatives Id DefBindee
-subst :: [(Id, CoreExpr Id DefBindee)] -> CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee
-union :: Eq a => [a] -> [a] -> [a]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DefUtils]{Miscellaneous Utility functions}
> atom2expr, newDefId, newTmpId, deforestable, foldrSUs,
> mkDefLetrec, subst, freeTyVars, union, consistent, RenameResult(..),
> isArgId
-> )
+> )
> where
> import DefSyn
> import Trace
>#endif
-> import AbsUniType ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
+> import Type ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
> extractTyVarsFromTy, TyVar, SigmaType(..)
> IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
> )
-> import BasicLit ( BasicLit ) -- for Eq BasicLit
+> import Literal ( Literal ) -- for Eq Literal
> import CoreSyn
> import Id ( mkIdWithNewUniq, mkSysLocal, applyTypeEnvToId,
-> getIdInfo, toplevelishId, getIdUniType, Id )
-> import IdEnv
+> getIdInfo, toplevelishId, idType, Id )
> import IdInfo
> import Outputable
> import Pretty
-> import PrimOps ( PrimOp ) -- for Eq PrimOp
-> import SplitUniq
+> import PrimOp ( PrimOp ) -- for Eq PrimOp
+> import UniqSupply
> import SrcLoc ( mkUnknownSrcLoc )
-> import TyVarEnv
> import Util
-----------------------------------------------------------------------------
> strip :: DefExpr -> DefExpr
> strip e' = case e' of
-> CoVar (DefArgExpr e) -> panic "DefUtils(strip): CoVar (DefExpr _)"
-> CoVar (Label l e) -> l
-> CoVar (DefArgVar v) -> e'
-> CoLit l -> e'
-> CoCon c ts es -> CoCon c ts (map stripAtom es)
-> CoPrim op ts es -> CoPrim op ts (map stripAtom es)
-> CoLam vs e -> CoLam vs (strip e)
+> Var (DefArgExpr e) -> panic "DefUtils(strip): Var (DefExpr _)"
+> Var (Label l e) -> l
+> Var (DefArgVar v) -> e'
+> Lit l -> e'
+> Con c ts es -> Con c ts (map stripAtom es)
+> Prim op ts es -> Prim op ts (map stripAtom es)
+> Lam vs e -> Lam vs (strip e)
> CoTyLam alpha e -> CoTyLam alpha (strip e)
-> CoApp e v -> CoApp (strip e) (stripAtom v)
+> App e v -> App (strip e) (stripAtom v)
> CoTyApp e t -> CoTyApp (strip e) t
-> CoCase e ps -> CoCase (strip e) (stripCaseAlts ps)
-> CoLet (CoNonRec v e) e' -> CoLet (CoNonRec v (strip e)) (strip e')
-> CoLet (CoRec bs) e ->
-> CoLet (CoRec [ (v, strip e) | (v,e) <- bs ]) (strip e)
-> CoSCC l e -> CoSCC l (strip e)
+> Case e ps -> Case (strip e) (stripCaseAlts ps)
+> Let (NonRec v e) e' -> Let (NonRec v (strip e)) (strip e')
+> Let (Rec bs) e ->
+> Let (Rec [ (v, strip e) | (v,e) <- bs ]) (strip e)
+> SCC l e -> SCC l (strip e)
> stripAtom :: DefAtom -> DefAtom
-> stripAtom (CoVarAtom v) = CoVarAtom (stripArg v)
-> stripAtom (CoLitAtom l) = CoLitAtom l -- XXX
+> stripAtom (VarArg v) = VarArg (stripArg v)
+> stripAtom (LitArg l) = LitArg l -- XXX
> stripArg :: DefBindee -> DefBindee
> stripArg (DefArgExpr e) = DefArgExpr (strip e)
> stripArg (Label l e) = panic "DefUtils(stripArg): Label _ _"
> stripArg (DefArgVar v) = panic "DefUtils(stripArg): DefArgVar _ _"
-> stripCaseAlts (CoAlgAlts as def)
-> = CoAlgAlts (map stripAlgAlt as) (stripDefault def)
-> stripCaseAlts (CoPrimAlts as def)
-> = CoPrimAlts (map stripPrimAlt as) (stripDefault def)
+> stripCaseAlts (AlgAlts as def)
+> = AlgAlts (map stripAlgAlt as) (stripDefault def)
+> stripCaseAlts (PrimAlts as def)
+> = PrimAlts (map stripPrimAlt as) (stripDefault def)
> stripAlgAlt (c, vs, e) = (c, vs, strip e)
> stripPrimAlt (l, e) = (l, strip e)
-> stripDefault CoNoDefault = CoNoDefault
-> stripDefault (CoBindDefault v e) = CoBindDefault v (strip e)
+> stripDefault NoDefault = NoDefault
+> stripDefault (BindDefault v e) = BindDefault v (strip e)
-----------------------------------------------------------------------------
\subsection{Free Variables}
> freeVars :: DefExpr -> [Id]
> freeVars e = free e []
-> where
+> where
> free e fvs = case e of
-> CoVar (DefArgExpr e) ->
-> panic "DefUtils(free): CoVar (DefExpr _)"
-> CoVar (Label l e) -> free l fvs
-> CoVar (DefArgVar v)
+> Var (DefArgExpr e) ->
+> panic "DefUtils(free): Var (DefExpr _)"
+> Var (Label l e) -> free l fvs
+> Var (DefArgVar v)
> | v `is_elem` fvs -> fvs
> | otherwise -> v : fvs
> where { is_elem = isIn "freeVars(deforest)" }
-> CoLit l -> fvs
-> CoCon c ts es -> foldr freeAtom fvs es
-> CoPrim op ts es -> foldr freeAtom fvs es
-> CoLam vs e -> free' vs (free e fvs)
+> Lit l -> fvs
+> Con c ts es -> foldr freeAtom fvs es
+> Prim op ts es -> foldr freeAtom fvs es
+> Lam vs e -> free' vs (free e fvs)
> CoTyLam alpha e -> free e fvs
-> CoApp e v -> free e (freeAtom v fvs)
+> App e v -> free e (freeAtom v fvs)
> CoTyApp e t -> free e fvs
-> CoCase e ps -> free e (freeCaseAlts ps fvs)
-> CoLet (CoNonRec v e) e' -> free e (free' [v] (free e' fvs))
-> CoLet (CoRec bs) e -> free' vs (foldr free (free e fvs) es)
+> Case e ps -> free e (freeCaseAlts ps fvs)
+> Let (NonRec v e) e' -> free e (free' [v] (free e' fvs))
+> Let (Rec bs) e -> free' vs (foldr free (free e fvs) es)
> where (vs,es) = unzip bs
-> CoSCC l e -> free e fvs
+> SCC l e -> free e fvs
> free' :: [Id] -> [Id] -> [Id]
> free' vs fvs = filter (\x -> notElem x vs) fvs
-> freeAtom (CoVarAtom (DefArgExpr e)) fvs = free e fvs
-> freeAtom (CoVarAtom (Label l e)) fvs
-> = panic "DefUtils(free): CoVarAtom (Label _ _)"
-> freeAtom (CoVarAtom (DefArgVar v)) fvs
-> = panic "DefUtils(free): CoVarAtom (DefArgVar _ _)"
-> freeAtom (CoLitAtom l) fvs = fvs
+> freeAtom (VarArg (DefArgExpr e)) fvs = free e fvs
+> freeAtom (VarArg (Label l e)) fvs
+> = panic "DefUtils(free): VarArg (Label _ _)"
+> freeAtom (VarArg (DefArgVar v)) fvs
+> = panic "DefUtils(free): VarArg (DefArgVar _ _)"
+> freeAtom (LitArg l) fvs = fvs
-> freeCaseAlts (CoAlgAlts as def) fvs
+> freeCaseAlts (AlgAlts as def) fvs
> = foldr freeAlgAlt (freeDefault def fvs) as
-> freeCaseAlts (CoPrimAlts as def) fvs
+> freeCaseAlts (PrimAlts as def) fvs
> = foldr freePrimAlt (freeDefault def fvs) as
->
+>
> freeAlgAlt (c, vs, e) fvs = free' vs (free e fvs)
> freePrimAlt (l, e) fvs = free e fvs
-> freeDefault CoNoDefault fvs = fvs
-> freeDefault (CoBindDefault v e) fvs = free' [v] (free e fvs)
+> freeDefault NoDefault fvs = fvs
+> freeDefault (BindDefault v e) fvs = free' [v] (free e fvs)
-----------------------------------------------------------------------------
\subsection{Free Type Variables}
> freeTyVars e = free e []
> where
> free e tvs = case e of
-> CoVar (DefArgExpr e) ->
-> panic "DefUtils(freeVars): CoVar (DefExpr _)"
-> CoVar (Label l e) -> free l tvs
-> CoVar (DefArgVar id) -> freeId id tvs
-> CoLit l -> tvs
-> CoCon c ts es -> foldr freeTy (foldr freeAtom tvs es) ts
-> CoPrim op ts es -> foldr freeTy (foldr freeAtom tvs es) ts
-> CoLam vs e -> foldr freeId (free e tvs) vs
+> Var (DefArgExpr e) ->
+> panic "DefUtils(freeVars): Var (DefExpr _)"
+> Var (Label l e) -> free l tvs
+> Var (DefArgVar id) -> freeId id tvs
+> Lit l -> tvs
+> Con c ts es -> foldr freeTy (foldr freeAtom tvs es) ts
+> Prim op ts es -> foldr freeTy (foldr freeAtom tvs es) ts
+> Lam vs e -> foldr freeId (free e tvs) vs
> CoTyLam alpha e -> filter (/= alpha) (free e tvs)
-> CoApp e v -> free e (freeAtom v tvs)
+> App e v -> free e (freeAtom v tvs)
> CoTyApp e t -> free e (freeTy t tvs)
-> CoCase e ps -> free e (freeCaseAlts ps tvs)
-> CoLet (CoNonRec v e) e' -> free e (freeId v (free e' tvs))
-> CoLet (CoRec bs) e -> foldr freeBind (free e tvs) bs
-> CoSCC l e -> free e tvs
->
-> freeId id tvs = extractTyVarsFromTy (getIdUniType id) `union` tvs
+> Case e ps -> free e (freeCaseAlts ps tvs)
+> Let (NonRec v e) e' -> free e (freeId v (free e' tvs))
+> Let (Rec bs) e -> foldr freeBind (free e tvs) bs
+> SCC l e -> free e tvs
+>
+> freeId id tvs = extractTyVarsFromTy (idType id) `union` tvs
> freeTy t tvs = extractTyVarsFromTy t `union` tvs
> freeBind (v,e) tvs = freeId v (free e tvs)
-
-> freeAtom (CoVarAtom (DefArgExpr e)) tvs = free e tvs
-> freeAtom (CoVarAtom (Label l e)) tvs
-> = panic "DefUtils(freeVars): CoVarAtom (Label _ _)"
-> freeAtom (CoVarAtom (DefArgVar v)) tvs
-> = panic "DefUtils(freeVars): CoVarAtom (DefArgVar _ _)"
-> freeAtom (CoLitAtom l) tvs = tvs -- XXX
-
-> freeCaseAlts (CoAlgAlts as def) tvs
+
+> freeAtom (VarArg (DefArgExpr e)) tvs = free e tvs
+> freeAtom (VarArg (Label l e)) tvs
+> = panic "DefUtils(freeVars): VarArg (Label _ _)"
+> freeAtom (VarArg (DefArgVar v)) tvs
+> = panic "DefUtils(freeVars): VarArg (DefArgVar _ _)"
+> freeAtom (LitArg l) tvs = tvs -- XXX
+
+> freeCaseAlts (AlgAlts as def) tvs
> = foldr freeAlgAlt (freeDefault def tvs) as
-> freeCaseAlts (CoPrimAlts as def) tvs
+> freeCaseAlts (PrimAlts as def) tvs
> = foldr freePrimAlt (freeDefault def tvs) as
> freeAlgAlt (c, vs, e) tvs = foldr freeId (free e tvs) vs
> freePrimAlt (l, e) tvs = free e tvs
-> freeDefault CoNoDefault tvs = tvs
-> freeDefault (CoBindDefault v e) tvs = freeId v (free e tvs)
+> freeDefault NoDefault tvs = tvs
+> freeDefault (BindDefault v e) tvs = freeId v (free e tvs)
-----------------------------------------------------------------------------
\subsection{Rebinding variables in an expression}
Here is the code that renames all the bound variables in an expression
with new uniques. Free variables are left unchanged.
-> rebindExpr :: DefExpr -> SUniqSM DefExpr
+> rebindExpr :: DefExpr -> UniqSM DefExpr
> rebindExpr e = uniqueExpr nullIdEnv nullTyVarEnv e
-> uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> SUniqSM DefExpr
+> uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> UniqSM DefExpr
> uniqueExpr p t e =
> case e of
-> CoVar (DefArgVar v) ->
-> returnSUs (CoVar (DefArgVar (lookup v p)))
->
-> CoVar (Label l e) ->
-> uniqueExpr p t l `thenSUs` \l ->
-> uniqueExpr p t e `thenSUs` \e ->
-> returnSUs (mkLabel l e)
->
-> CoVar (DefArgExpr _) ->
-> panic "DefUtils(uniqueExpr): CoVar(DefArgExpr _)"
->
-> CoLit l ->
-> returnSUs e
->
-> CoCon c ts es ->
-> mapSUs (uniqueAtom p t) es `thenSUs` \es ->
-> returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es)
->
-> CoPrim op ts es ->
-> mapSUs (uniqueAtom p t) es `thenSUs` \es ->
-> returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es)
->
-> CoLam vs e ->
-> mapSUs (newVar t) vs `thenSUs` \vs' ->
-> uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenSUs` \e ->
-> returnSUs (CoLam vs' e)
->
+> Var (DefArgVar v) ->
+> returnUs (Var (DefArgVar (lookup v p)))
+>
+> Var (Label l e) ->
+> uniqueExpr p t l `thenUs` \l ->
+> uniqueExpr p t e `thenUs` \e ->
+> returnUs (mkLabel l e)
+>
+> Var (DefArgExpr _) ->
+> panic "DefUtils(uniqueExpr): Var(DefArgExpr _)"
+>
+> Lit l ->
+> returnUs e
+>
+> Con c ts es ->
+> mapUs (uniqueAtom p t) es `thenUs` \es ->
+> returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
+>
+> Prim op ts es ->
+> mapUs (uniqueAtom p t) es `thenUs` \es ->
+> returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
+>
+> Lam vs e ->
+> mapUs (newVar t) vs `thenUs` \vs' ->
+> uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenUs` \e ->
+> returnUs (Lam vs' e)
+>
> CoTyLam v e ->
-> getSUnique `thenSUs` \u ->
+> getUnique `thenUs` \u ->
> let v' = cloneTyVar v u
> t' = addOneToTyVarEnv t v (mkTyVarTy v') in
-> uniqueExpr p t' e `thenSUs` \e ->
-> returnSUs (CoTyLam v' e)
->
-> CoApp e v ->
-> uniqueExpr p t e `thenSUs` \e ->
-> uniqueAtom p t v `thenSUs` \v ->
-> returnSUs (CoApp e v)
->
+> uniqueExpr p t' e `thenUs` \e ->
+> returnUs (CoTyLam v' e)
+>
+> App e v ->
+> uniqueExpr p t e `thenUs` \e ->
+> uniqueAtom p t v `thenUs` \v ->
+> returnUs (App e v)
+>
> CoTyApp e ty ->
-> uniqueExpr p t e `thenSUs` \e ->
-> returnSUs (mkCoTyApp e (applyTypeEnvToTy t ty))
->
-> CoCase e alts ->
-> uniqueExpr p t e `thenSUs` \e ->
-> uniqueAlts alts `thenSUs` \alts ->
-> returnSUs (CoCase e alts)
+> uniqueExpr p t e `thenUs` \e ->
+> returnUs (CoTyApp e (applyTypeEnvToTy t ty))
+>
+> Case e alts ->
+> uniqueExpr p t e `thenUs` \e ->
+> uniqueAlts alts `thenUs` \alts ->
+> returnUs (Case e alts)
> where
-> uniqueAlts (CoAlgAlts as d) =
-> mapSUs uniqueAlgAlt as `thenSUs` \as ->
-> uniqueDefault d `thenSUs` \d ->
-> returnSUs (CoAlgAlts as d)
-> uniqueAlts (CoPrimAlts as d) =
-> mapSUs uniquePrimAlt as `thenSUs` \as ->
-> uniqueDefault d `thenSUs` \d ->
-> returnSUs (CoPrimAlts as d)
->
-> uniqueAlgAlt (c, vs, e) =
-> mapSUs (newVar t) vs `thenSUs` \vs' ->
-> uniqueExpr (growIdEnvList p (zip vs vs')) t e
-> `thenSUs` \e ->
-> returnSUs (c, vs', e)
+> uniqueAlts (AlgAlts as d) =
+> mapUs uniqueAlgAlt as `thenUs` \as ->
+> uniqueDefault d `thenUs` \d ->
+> returnUs (AlgAlts as d)
+> uniqueAlts (PrimAlts as d) =
+> mapUs uniquePrimAlt as `thenUs` \as ->
+> uniqueDefault d `thenUs` \d ->
+> returnUs (PrimAlts as d)
+>
+> uniqueAlgAlt (c, vs, e) =
+> mapUs (newVar t) vs `thenUs` \vs' ->
+> uniqueExpr (growIdEnvList p (zip vs vs')) t e
+> `thenUs` \e ->
+> returnUs (c, vs', e)
> uniquePrimAlt (l, e) =
-> uniqueExpr p t e `thenSUs` \e ->
-> returnSUs (l, e)
->
-> uniqueDefault CoNoDefault = returnSUs CoNoDefault
-> uniqueDefault (CoBindDefault v e) =
-> newVar t v `thenSUs` \v' ->
-> uniqueExpr (addOneToIdEnv p v v') t e `thenSUs` \e ->
-> returnSUs (CoBindDefault v' e)
->
-> CoLet (CoNonRec v e) e' ->
-> uniqueExpr p t e `thenSUs` \e ->
-> newVar t v `thenSUs` \v' ->
-> uniqueExpr (addOneToIdEnv p v v') t e' `thenSUs` \e' ->
-> returnSUs (CoLet (CoNonRec v' e) e')
->
-> CoLet (CoRec ds) e ->
+> uniqueExpr p t e `thenUs` \e ->
+> returnUs (l, e)
+>
+> uniqueDefault NoDefault = returnUs NoDefault
+> uniqueDefault (BindDefault v e) =
+> newVar t v `thenUs` \v' ->
+> uniqueExpr (addOneToIdEnv p v v') t e `thenUs` \e ->
+> returnUs (BindDefault v' e)
+>
+> Let (NonRec v e) e' ->
+> uniqueExpr p t e `thenUs` \e ->
+> newVar t v `thenUs` \v' ->
+> uniqueExpr (addOneToIdEnv p v v') t e' `thenUs` \e' ->
+> returnUs (Let (NonRec v' e) e')
+>
+> Let (Rec ds) e ->
> let (vs,es) = unzip ds in
-> mapSUs (newVar t) vs `thenSUs` \vs' ->
+> mapUs (newVar t) vs `thenUs` \vs' ->
> let p' = growIdEnvList p (zip vs vs') in
-> mapSUs (uniqueExpr p' t) es `thenSUs` \es ->
-> uniqueExpr p' t e `thenSUs` \e ->
-> returnSUs (CoLet (CoRec (zip vs' es)) e)
->
-> CoSCC l e ->
-> uniqueExpr p t e `thenSUs` \e ->
-> returnSUs (CoSCC l e)
->
->
-> uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> SUniqSM DefAtom
-> uniqueAtom p t (CoLitAtom l) = returnSUs (CoLitAtom l) -- XXX
-> uniqueAtom p t (CoVarAtom v) =
-> uniqueArg p t v `thenSUs` \v ->
-> returnSUs (CoVarAtom v)
->
+> mapUs (uniqueExpr p' t) es `thenUs` \es ->
+> uniqueExpr p' t e `thenUs` \e ->
+> returnUs (Let (Rec (zip vs' es)) e)
+>
+> SCC l e ->
+> uniqueExpr p t e `thenUs` \e ->
+> returnUs (SCC l e)
+>
+>
+> uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> UniqSM DefAtom
+> uniqueAtom p t (LitArg l) = returnUs (LitArg l) -- XXX
+> uniqueAtom p t (VarArg v) =
+> uniqueArg p t v `thenUs` \v ->
+> returnUs (VarArg v)
+>
> uniqueArg p t (DefArgVar v) =
> panic "DefUtils(uniqueArg): DefArgVar _ _"
> uniqueArg p t (DefArgExpr e) =
-> uniqueExpr p t e `thenSUs` \e ->
-> returnSUs (DefArgExpr e)
+> uniqueExpr p t e `thenUs` \e ->
+> returnUs (DefArgExpr e)
> uniqueArg p t (Label l e) =
> panic "DefUtils(uniqueArg): Label _ _"
> Nothing -> id
> Just new_id -> new_id
-> newVar :: TypeEnv -> Id -> SUniqSM Id
-> newVar t id =
-> getSUnique `thenSUs` \u ->
-> returnSUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
+> newVar :: TypeEnv -> Id -> UniqSM Id
+> newVar t id =
+> getUnique `thenUs` \u ->
+> returnUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
-----------------------------------------------------------------------------
\subsection{Detecting Renamings}
We only allow renaming of sysLocal ids - ie. not top-level, imported
or otherwise global ids.
-> data RenameResult
+> data RenameResult
> = NotRenaming
> | IsRenaming [(Id,Id)]
> | InconsistentRenaming [(Id,Id)]
-> renameExprs :: DefExpr -> DefExpr -> SUniqSM RenameResult
-> renameExprs u u' =
+> renameExprs :: DefExpr -> DefExpr -> UniqSM RenameResult
+> renameExprs u u' =
> case ren u u' of
-> [] -> returnSUs NotRenaming
-> [r] -> if not (consistent r) then
-> d2c (strip u) `thenSUs` \u ->
-> d2c (strip u') `thenSUs` \u' ->
+> [] -> returnUs NotRenaming
+> [r] -> if not (consistent r) then
+> d2c (strip u) `thenUs` \u ->
+> d2c (strip u') `thenUs` \u' ->
> trace ("failed consistency check:\n" ++
> ppShow 80 (ppr PprDebug u) ++ "\n" ++
> ppShow 80 (ppr PprDebug u'))
-> (returnSUs (InconsistentRenaming r))
-> else
-> trace "Renaming!" (returnSUs (IsRenaming r))
+> (returnUs (InconsistentRenaming r))
+> else
+> trace "Renaming!" (returnUs (IsRenaming r))
> _ -> panic "DefUtils(renameExprs)"
Check that we have a consistent renaming. A renaming is consistent if
> checkConsistency :: [(Id,Id)] -> [[(Id,Id)]] -> [[(Id,Id)]]
> checkConsistency bound free = [ r' | r <- free, r' <- check r ]
-> where
+> where
> check r | they're_consistent = [frees]
> | otherwise = []
-> where
+> where
> (bounds,frees) = partition (\(a,b) -> a `elem` lbound) r
> (lbound,rbound) = unzip bound
> they're_consistent = consistent (bound ++ bounds)
comparing the expressions.
> ren :: DefExpr -> DefExpr -> [[(Id,Id)]]
->
+>
> -- renaming or identical cases --
->
+>
>
> -- same variable, no renaming
-> ren (CoVar (DefArgVar x)) t@(CoVar (DefArgVar y))
+> ren (Var (DefArgVar x)) t@(Var (DefArgVar y))
> | x == y = [[(x,y)]]
> | isArgId x && isArgId y = [[(x,y)]]
>
> -- if we're doing matching, use the next rule,
> -- and delete the second clause in the above rule.
> {-
-> ren (CoVar (DefArgVar x)) t
+> ren (Var (DefArgVar x)) t
> | okToRename x && all (not. deforestable) (freeVars t)
> = [[(x,t)]]
> -}
-> ren (CoLit l) (CoLit l') | l == l'
+> ren (Lit l) (Lit l') | l == l'
> = [[]]
-> ren (CoCon c ts es) (CoCon c' ts' es') | c == c'
+> ren (Con c ts es) (Con c' ts' es') | c == c'
> = foldr (....) [[]] (zipWith renAtom es es')
-> ren (CoPrim op ts es) (CoPrim op' ts' es') | op == op'
+> ren (Prim op ts es) (Prim op' ts' es') | op == op'
> = foldr (....) [[]] (zipWith renAtom es es')
-> ren (CoLam vs e) (CoLam vs' e')
+> ren (Lam vs e) (Lam vs' e')
> = checkConsistency (zip vs vs') (ren e e')
> ren (CoTyLam vs e) (CoTyLam vs' e')
> = ren e e' -- XXX!
-> ren (CoApp e v) (CoApp e' v')
+> ren (App e v) (App e' v')
> = ren e e' .... renAtom v v'
> ren (CoTyApp e t) (CoTyApp e' t')
> = ren e e' -- XXX!
-> ren (CoCase e alts) (CoCase e' alts')
+> ren (Case e alts) (Case e' alts')
> = ren e e' .... renAlts alts alts'
-> ren (CoLet (CoNonRec v a) b) (CoLet (CoNonRec v' a') b')
+> ren (Let (NonRec v a) b) (Let (NonRec v' a') b')
> = ren a a' .... (checkConsistency [(v,v')] (ren b b'))
-> ren (CoLet (CoRec ds) e) (CoLet (CoRec ds') e')
-> = checkConsistency (zip vs vs')
+> ren (Let (Rec ds) e) (Let (Rec ds') e')
+> = checkConsistency (zip vs vs')
> (ren e e' .... (foldr (....) [[]] (zipWith ren es es')))
> where (vs ,es ) = unzip ds
> (vs',es') = unzip ds'
->
+>
> -- label cases --
->
-> ren (CoVar (Label l e)) e' = ren l e'
-> ren e (CoVar (Label l e')) = ren e l
+>
+> ren (Var (Label l e)) e' = ren l e'
+> ren e (Var (Label l e')) = ren e l
>
> -- error cases --
->
-> ren (CoVar (DefArgExpr _)) _
-> = panic "DefUtils(ren): CoVar (DefArgExpr _)"
-> ren _ (CoVar (DefArgExpr _))
-> = panic "DefUtils(ren): CoVar (DefArgExpr _)"
->
+>
+> ren (Var (DefArgExpr _)) _
+> = panic "DefUtils(ren): Var (DefArgExpr _)"
+> ren _ (Var (DefArgExpr _))
+> = panic "DefUtils(ren): Var (DefArgExpr _)"
+>
> -- default case --
->
-> ren _ _ = []
+>
+> ren _ _ = []
Rename atoms.
-> renAtom (CoVarAtom (DefArgExpr e)) (CoVarAtom (DefArgExpr e'))
+> renAtom (VarArg (DefArgExpr e)) (VarArg (DefArgExpr e'))
> = ren e e'
> -- XXX shouldn't need the next two
-> renAtom (CoLitAtom l) (CoLitAtom l') | l == l' = [[]]
-> renAtom (CoVarAtom (DefArgVar v)) _ =
-> panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)"
-> renAtom _ (CoVarAtom (DefArgVar v)) =
-> panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)"
-> renAtom (CoVarAtom (Label _ _)) _ =
-> panic "DefUtils(renAtom): CoVarAtom (Label _ _)"
-> renAtom e (CoVarAtom (Label l e')) =
-> panic "DefUtils(renAtom): CoVarAtom (Label _ _)"
->
+> renAtom (LitArg l) (LitArg l') | l == l' = [[]]
+> renAtom (VarArg (DefArgVar v)) _ =
+> panic "DefUtils(renAtom): VarArg (DefArgVar _ _)"
+> renAtom _ (VarArg (DefArgVar v)) =
+> panic "DefUtils(renAtom): VarArg (DefArgVar _ _)"
+> renAtom (VarArg (Label _ _)) _ =
+> panic "DefUtils(renAtom): VarArg (Label _ _)"
+> renAtom e (VarArg (Label l e')) =
+> panic "DefUtils(renAtom): VarArg (Label _ _)"
+>
> renAtom _ _ = []
Renamings of case alternatives doesn't allow reordering, but that
should be Ok (we don't ever change the ordering anyway).
-> renAlts (CoAlgAlts as dflt) (CoAlgAlts as' dflt')
+> renAlts (AlgAlts as dflt) (AlgAlts as' dflt')
> = foldr (....) [[]] (zipWith renAlgAlt as as') .... renDefault dflt dflt'
-> renAlts (CoPrimAlts as dflt) (CoPrimAlts as' dflt')
+> renAlts (PrimAlts as dflt) (PrimAlts as' dflt')
> = foldr (....) [[]] (zipWith renPrimAlt as as') .... renDefault dflt dflt'
> renAlts _ _ = []
->
-> renAlgAlt (c,vs,e) (c',vs',e') | c == c'
+>
+> renAlgAlt (c,vs,e) (c',vs',e') | c == c'
> = checkConsistency (zip vs vs') (ren e e')
> renAlgAlt _ _ = []
->
+>
> renPrimAlt (l,e) (l',e') | l == l' = ren e e'
> renPrimAlt _ _ = []
>
-> renDefault CoNoDefault CoNoDefault = [[]]
-> renDefault (CoBindDefault v e) (CoBindDefault v' e')
+> renDefault NoDefault NoDefault = [[]]
+> renDefault (BindDefault v e) (BindDefault v' e')
> = checkConsistency [(v,v')] (ren e e')
-----------------------------------------------------------------------------
> atom2expr :: DefAtom -> DefExpr
-> atom2expr (CoVarAtom (DefArgExpr e)) = e
-> atom2expr (CoVarAtom (Label l e)) = mkLabel l e
+> atom2expr (VarArg (DefArgExpr e)) = e
+> atom2expr (VarArg (Label l e)) = mkLabel l e
> -- XXX next two should be illegal
-> atom2expr (CoLitAtom l) = CoLit l
-> atom2expr (CoVarAtom (DefArgVar v)) =
-> panic "DefUtils(atom2expr): CoVarAtom (DefArgVar _)"
+> atom2expr (LitArg l) = Lit l
+> atom2expr (VarArg (DefArgVar v)) =
+> panic "DefUtils(atom2expr): VarArg (DefArgVar _)"
-> expr2atom = CoVarAtom . DefArgExpr
+> expr2atom = VarArg . DefArgExpr
-----------------------------------------------------------------------------
Grab a new Id and tag it as coming from the Deforester.
-> newDefId :: UniType -> SUniqSM Id
-> newDefId t =
-> getSUnique `thenSUs` \u ->
-> returnSUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
+> newDefId :: Type -> UniqSM Id
+> newDefId t =
+> getUnique `thenUs` \u ->
+> returnUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
-> newTmpId :: UniType -> SUniqSM Id
+> newTmpId :: Type -> UniqSM Id
> newTmpId t =
-> getSUnique `thenSUs` \u ->
-> returnSUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
+> getUnique `thenUs` \u ->
+> returnUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
-----------------------------------------------------------------------------
Check whether an Id was given a `DEFOREST' annotation by the programmer.
-----------------------------------------------------------------------------
Filter for free variables to abstract from new functions.
-> isArgId id
-> = (not . deforestable) id
-> && (not . toplevelishId) id
+> isArgId id
+> = (not . deforestable) id
+> && (not . toplevelishId) id
-----------------------------------------------------------------------------
-> foldrSUs f c [] = returnSUs c
+> foldrSUs f c [] = returnUs c
> foldrSUs f c (x:xs)
-> = foldrSUs f c xs `thenSUs` \xs' ->
+> = foldrSUs f c xs `thenUs` \xs' ->
> f x xs'
-----------------------------------------------------------------------------
> mkDefLetrec [] e = e
-> mkDefLetrec bs e = CoLet (CoRec bs) e
+> mkDefLetrec bs e = Let (Rec bs) e
-----------------------------------------------------------------------------
Substitutions.
> subst :: [(Id,DefExpr)]
> -> DefExpr
-> -> SUniqSM DefExpr
+> -> UniqSM DefExpr
> subst p e' = sub e'
> where
> p' = mkIdEnv p
> sub e' = case e' of
-> CoVar (DefArgExpr e) -> panic "DefExpr(sub): CoVar (DefArgExpr _)"
-> CoVar (Label l e) -> panic "DefExpr(sub): CoVar (Label _ _)"
-> CoVar (DefArgVar v) ->
+> Var (DefArgExpr e) -> panic "DefExpr(sub): Var (DefArgExpr _)"
+> Var (Label l e) -> panic "DefExpr(sub): Var (Label _ _)"
+> Var (DefArgVar v) ->
> case lookupIdEnv p' v of
-> Just e -> rebindExpr e `thenSUs` \e -> returnSUs e
-> Nothing -> returnSUs e'
-> CoLit l -> returnSUs e'
-> CoCon c ts es -> mapSUs substAtom es `thenSUs` \es ->
-> returnSUs (CoCon c ts es)
-> CoPrim op ts es -> mapSUs substAtom es `thenSUs` \es ->
-> returnSUs (CoPrim op ts es)
-> CoLam vs e -> sub e `thenSUs` \e ->
-> returnSUs (CoLam vs e)
-> CoTyLam alpha e -> sub e `thenSUs` \e ->
-> returnSUs (CoTyLam alpha e)
-> CoApp e v -> sub e `thenSUs` \e ->
-> substAtom v `thenSUs` \v ->
-> returnSUs (CoApp e v)
-> CoTyApp e t -> sub e `thenSUs` \e ->
-> returnSUs (CoTyApp e t)
-> CoCase e ps -> sub e `thenSUs` \e ->
-> substCaseAlts ps `thenSUs` \ps ->
-> returnSUs (CoCase e ps)
-> CoLet (CoNonRec v e) e'
-> -> sub e `thenSUs` \e ->
-> sub e' `thenSUs` \e' ->
-> returnSUs (CoLet (CoNonRec v e) e')
-> CoLet (CoRec bs) e -> sub e `thenSUs` \e ->
-> mapSUs substBind bs `thenSUs` \bs ->
-> returnSUs (CoLet (CoRec bs) e)
+> Just e -> rebindExpr e `thenUs` \e -> returnUs e
+> Nothing -> returnUs e'
+> Lit l -> returnUs e'
+> Con c ts es -> mapUs substAtom es `thenUs` \es ->
+> returnUs (Con c ts es)
+> Prim op ts es -> mapUs substAtom es `thenUs` \es ->
+> returnUs (Prim op ts es)
+> Lam vs e -> sub e `thenUs` \e ->
+> returnUs (Lam vs e)
+> CoTyLam alpha e -> sub e `thenUs` \e ->
+> returnUs (CoTyLam alpha e)
+> App e v -> sub e `thenUs` \e ->
+> substAtom v `thenUs` \v ->
+> returnUs (App e v)
+> CoTyApp e t -> sub e `thenUs` \e ->
+> returnUs (CoTyApp e t)
+> Case e ps -> sub e `thenUs` \e ->
+> substCaseAlts ps `thenUs` \ps ->
+> returnUs (Case e ps)
+> Let (NonRec v e) e'
+> -> sub e `thenUs` \e ->
+> sub e' `thenUs` \e' ->
+> returnUs (Let (NonRec v e) e')
+> Let (Rec bs) e -> sub e `thenUs` \e ->
+> mapUs substBind bs `thenUs` \bs ->
+> returnUs (Let (Rec bs) e)
> where
-> substBind (v,e) =
-> sub e `thenSUs` \e ->
-> returnSUs (v,e)
-> CoSCC l e -> sub e `thenSUs` \e ->
-> returnSUs (CoSCC l e)
-
-> substAtom (CoVarAtom v) =
-> substArg v `thenSUs` \v ->
-> returnSUs (CoVarAtom v)
-> substAtom (CoLitAtom l) =
-> returnSUs (CoLitAtom l) -- XXX
-
-> substArg (DefArgExpr e) =
-> sub e `thenSUs` \e ->
-> returnSUs (DefArgExpr e)
-> substArg e@(Label _ _) =
+> substBind (v,e) =
+> sub e `thenUs` \e ->
+> returnUs (v,e)
+> SCC l e -> sub e `thenUs` \e ->
+> returnUs (SCC l e)
+
+> substAtom (VarArg v) =
+> substArg v `thenUs` \v ->
+> returnUs (VarArg v)
+> substAtom (LitArg l) =
+> returnUs (LitArg l) -- XXX
+
+> substArg (DefArgExpr e) =
+> sub e `thenUs` \e ->
+> returnUs (DefArgExpr e)
+> substArg e@(Label _ _) =
> panic "DefExpr(substArg): Label _ _"
> substArg e@(DefArgVar v) = -- XXX
> case lookupIdEnv p' v of
-> Just e -> rebindExpr e `thenSUs` \e ->
-> returnSUs (DefArgExpr e)
-> Nothing -> returnSUs e
-
-> substCaseAlts (CoAlgAlts as def) =
-> mapSUs substAlgAlt as `thenSUs` \as ->
-> substDefault def `thenSUs` \def ->
-> returnSUs (CoAlgAlts as def)
-> substCaseAlts (CoPrimAlts as def) =
-> mapSUs substPrimAlt as `thenSUs` \as ->
-> substDefault def `thenSUs` \def ->
-> returnSUs (CoPrimAlts as def)
-
-> substAlgAlt (c, vs, e) =
-> sub e `thenSUs` \e ->
-> returnSUs (c, vs, e)
-> substPrimAlt (l, e) =
-> sub e `thenSUs` \e ->
-> returnSUs (l, e)
-
-> substDefault CoNoDefault =
-> returnSUs CoNoDefault
-> substDefault (CoBindDefault v e) =
-> sub e `thenSUs` \e ->
-> returnSUs (CoBindDefault v e)
+> Just e -> rebindExpr e `thenUs` \e ->
+> returnUs (DefArgExpr e)
+> Nothing -> returnUs e
+
+> substCaseAlts (AlgAlts as def) =
+> mapUs substAlgAlt as `thenUs` \as ->
+> substDefault def `thenUs` \def ->
+> returnUs (AlgAlts as def)
+> substCaseAlts (PrimAlts as def) =
+> mapUs substPrimAlt as `thenUs` \as ->
+> substDefault def `thenUs` \def ->
+> returnUs (PrimAlts as def)
+
+> substAlgAlt (c, vs, e) =
+> sub e `thenUs` \e ->
+> returnUs (c, vs, e)
+> substPrimAlt (l, e) =
+> sub e `thenUs` \e ->
+> returnUs (l, e)
+
+> substDefault NoDefault =
+> returnUs NoDefault
+> substDefault (BindDefault v e) =
+> sub e `thenUs` \e ->
+> returnUs (BindDefault v e)
-----------------------------------------------------------------------------
> union [] ys = ys
-> union (x:xs) ys
+> union (x:xs) ys
> | x `is_elem` ys = union xs ys
> | otherwise = x : union xs ys
> where { is_elem = isIn "union(deforest)" }
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface Deforest where
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-deforestProgram :: (GlobalSwitch -> SwitchResult) -> [CoreBinding Id Id] -> SplitUniqSupply -> [CoreBinding Id Id]
-
> import CmdLineOpts ( GlobalSwitch, SwitchResult )
> import CoreSyn
> import Id ( getIdInfo, Id )
-> import IdEnv
> import IdInfo
> import Outputable
> import SimplEnv ( SwitchChecker(..) )
-> import SplitUniq
-> import TyVarEnv
+> import UniqSupply
> import Util
> -- tmp, for traces
> -- stub (ToDo)
> domIdEnv = panic "Deforest: domIdEnv"
-> deforestProgram
+> deforestProgram
> :: SwitchChecker GlobalSwitch{-maybe-}
-> -> PlainCoreProgram
-> -> SplitUniqSupply
-> -> PlainCoreProgram
->
-> deforestProgram sw prog uq =
+> -> [CoreBinding]
+> -> UniqSupply
+> -> [CoreBinding]
+>
+> deforestProgram sw prog uq =
> let
> def_program = core2def sw prog
> out_program = (
-> defProg sw nullIdEnv def_program `thenSUs` \prog ->
+> defProg sw nullIdEnv def_program `thenUs` \prog ->
> def2core prog)
> uq
> in
function is annotated as deforestable, then it is converted to
treeless form for unfolding later on.
-Also converting non-recursive functions that are annotated with
-{-# DEFOREST #-} now. Probably don't need to convert these to treeless
+Also converting non-recursive functions that are annotated with
+{-# DEFOREST #-} now. Probably don't need to convert these to treeless
form: just the inner recursive bindings they contain. eg:
repeat = \x -> letrec xs = x:xs in xs
is non-recursive, but we want to unfold it and annotate the binding
for xs as unfoldable, too.
-> defProg
+> defProg
> :: SwitchChecker GlobalSwitch{-maybe-}
-> -> IdEnv DefExpr
-> -> [DefBinding]
-> -> SUniqSM [DefBinding]
->
-> defProg sw p [] = returnSUs []
->
-> defProg sw p (CoNonRec v e : bs) =
+> -> IdEnv DefExpr
+> -> [DefBinding]
+> -> UniqSM [DefBinding]
+>
+> defProg sw p [] = returnUs []
+>
+> defProg sw p (NonRec v e : bs) =
> trace ("Processing: `" ++
> ppShow 80 (ppr PprDebug v) ++ "'\n") (
-> tran sw p nullTyVarEnv e [] `thenSUs` \e ->
-> mkLoops e `thenSUs` \(extracted,e) ->
+> tran sw p nullTyVarEnv e [] `thenUs` \e ->
+> mkLoops e `thenUs` \(extracted,e) ->
> let e' = mkDefLetrec extracted e in
> (
> if deforestable v then
> let (vs,es) = unzip extracted in
-> convertToTreelessForm sw e `thenSUs` \e ->
-> mapSUs (convertToTreelessForm sw) es `thenSUs` \es ->
+> convertToTreelessForm sw e `thenUs` \e ->
+> mapUs (convertToTreelessForm sw) es `thenUs` \es ->
> defProg sw (growIdEnvList p ((v,e):zip vs es)) bs
> else
-> defProg sw p bs
-> ) `thenSUs` \bs ->
-> returnSUs (CoNonRec v e' : bs)
+> defProg sw p bs
+> ) `thenUs` \bs ->
+> returnUs (NonRec v e' : bs)
> )
->
-> defProg sw p (CoRec bs : bs') =
-> mapSUs (defRecBind sw p) bs `thenSUs` \res ->
+>
+> defProg sw p (Rec bs : bs') =
+> mapUs (defRecBind sw p) bs `thenUs` \res ->
> let
> (resid, unfold) = unzip res
> p' = growIdEnvList p (concat unfold)
> in
-> defProg sw p' bs' `thenSUs` \bs' ->
-> returnSUs (CoRec resid: bs')
+> defProg sw p' bs' `thenUs` \bs' ->
+> returnUs (Rec resid: bs')
-> defRecBind
+> defRecBind
> :: SwitchChecker GlobalSwitch{-maybe-}
-> -> IdEnv DefExpr
+> -> IdEnv DefExpr
> -> (Id,DefExpr)
-> -> SUniqSM ((Id,DefExpr),[(Id,DefExpr)])
->
+> -> UniqSM ((Id,DefExpr),[(Id,DefExpr)])
+>
> defRecBind sw p (v,e) =
> trace ("Processing: `" ++
> ppShow 80 (ppr PprDebug v) ++ "'\n") (
-> tran sw p nullTyVarEnv e [] `thenSUs` \e' ->
-> mkLoops e' `thenSUs` \(bs,e') ->
+> tran sw p nullTyVarEnv e [] `thenUs` \e' ->
+> mkLoops e' `thenUs` \(bs,e') ->
> let e'' = mkDefLetrec bs e' in
->
-> d2c e'' `thenSUs` \core_e ->
-> let showBind (v,e) = ppShow 80 (ppr PprDebug v) ++
-> "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
+>
+> d2c e'' `thenUs` \core_e ->
+> let showBind (v,e) = ppShow 80 (ppr PprDebug v) ++
+> "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
> in
-> trace ("Extracting from `" ++
+> trace ("Extracting from `" ++
> ppShow 80 (ppr PprDebug v) ++ "'\n"
> ++ "{ result:\n" ++ showBind (v,core_e) ++ "}\n") $
->
+>
> if deforestable v
-> then
+> then
> let (vs,es) = unzip bs in
-> convertToTreelessForm sw e' `thenSUs` \e' ->
-> mapSUs (convertToTreelessForm sw) es `thenSUs` \es ->
-> returnSUs ((v,e''),(v,e'):zip vs es)
-> else
+> convertToTreelessForm sw e' `thenUs` \e' ->
+> mapUs (convertToTreelessForm sw) es `thenUs` \es ->
+> returnUs ((v,e''),(v,e'):zip vs es)
+> else
> trace (show (length bs)) (
-> returnSUs ((v,e''),[])
+> returnUs ((v,e''),[])
> )
> )
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface TreelessForm where
-import CmdLineOpts(SwitchResult)
-import CoreSyn(CoreExpr)
-import DefSyn(DefBindee)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-convertToTreelessForm :: (a -> SwitchResult) -> CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee
-
> module TreelessForm (
> convertToTreelessForm
> ) where
->
+>
> import DefSyn
-> import PlainCore
> import DefUtils
-> import CoreFuns ( typeOfCoreExpr )
-> import IdEnv
> import CmdLineOpts ( SwitchResult, switchIsOn )
-> import SplitUniq
-> import SimplEnv ( SwitchChecker(..) )
-> import Maybes ( Maybe(..) )
+> import CoreUtils ( coreExprType )
> import Id ( replaceIdInfo, getIdInfo )
> import IdInfo
-> import Util
+> import Maybes ( Maybe(..) )
> import Outputable
-
+> import SimplEnv ( SwitchChecker(..) )
+> import UniqSupply
+> import Util
> -- tmp
> import Pretty
> convertToTreelessForm
> :: SwitchChecker sw
> -> DefExpr
-> -> SUniqSM DefExpr
->
+> -> UniqSM DefExpr
+>
> convertToTreelessForm sw e
> = convExpr e
>
> convExpr
> :: DefExpr
-> -> SUniqSM DefExpr
+> -> UniqSM DefExpr
> convExpr e = case e of
>
-> CoVar (DefArgExpr e) ->
-> panic "TreelessForm(substTy): CoVar (DefArgExpr _)"
->
-> CoVar (Label l e) ->
-> panic "TreelessForm(substTy): CoVar (Label _ _)"
->
-> CoVar (DefArgVar id) -> returnSUs e
->
-> CoLit l -> returnSUs e
->
-> CoCon c ts es ->
-> mapSUs convAtom es `thenSUs` \es ->
-> returnSUs (CoCon c ts es)
->
-> CoPrim op ts es ->
-> mapSUs convAtom es `thenSUs` \es ->
-> returnSUs (CoPrim op ts es)
->
-> CoLam vs e ->
-> convExpr e `thenSUs` \e ->
-> returnSUs (CoLam vs e)
->
-> CoTyLam alpha e ->
-> convExpr e `thenSUs` \e ->
-> returnSUs (CoTyLam alpha e)
->
-> CoApp e v ->
-> convExpr e `thenSUs` \e ->
+> Var (DefArgExpr e) ->
+> panic "TreelessForm(substTy): Var (DefArgExpr _)"
+>
+> Var (Label l e) ->
+> panic "TreelessForm(substTy): Var (Label _ _)"
+>
+> Var (DefArgVar id) -> returnUs e
+>
+> Lit l -> returnUs e
+>
+> Con c ts es ->
+> mapUs convAtom es `thenUs` \es ->
+> returnUs (Con c ts es)
+>
+> Prim op ts es ->
+> mapUs convAtom es `thenUs` \es ->
+> returnUs (Prim op ts es)
+>
+> Lam vs e ->
+> convExpr e `thenUs` \e ->
+> returnUs (Lam vs e)
+>
+> CoTyLam alpha e ->
+> convExpr e `thenUs` \e ->
+> returnUs (CoTyLam alpha e)
+>
+> App e v ->
+> convExpr e `thenUs` \e ->
> case v of
-> CoLitAtom l -> returnSUs (CoApp e v)
-> CoVarAtom v' ->
+> LitArg l -> returnUs (App e v)
+> VarArg v' ->
> case v' of
> DefArgVar _ -> panic "TreelessForm(convExpr): DefArgVar"
-> DefArgExpr (CoVar (DefArgVar id))
-> | (not.deforestable) id ->
-> returnSUs (CoApp e v)
-> DefArgExpr e' ->
-> newLet e' (\id -> CoApp e (CoVarAtom
+> DefArgExpr (Var (DefArgVar id))
+> | (not.deforestable) id ->
+> returnUs (App e v)
+> DefArgExpr e' ->
+> newLet e' (\id -> App e (VarArg
> (DefArgExpr id)))
->
-> CoTyApp e ty ->
-> convExpr e `thenSUs` \e ->
-> returnSUs (CoTyApp e ty)
->
-> CoCase e ps ->
-> convCaseAlts ps `thenSUs` \ps ->
-> case e of
-> CoVar (DefArgVar id) | (not.deforestable) id ->
-> returnSUs (CoCase e ps)
-> CoPrim op ts es -> returnSUs (CoCase e ps)
-> _ -> d2c e `thenSUs` \e' ->
-> newLet e (\v -> CoCase v ps)
->
-> CoLet (CoNonRec id e) e' ->
-> convExpr e `thenSUs` \e ->
-> convExpr e' `thenSUs` \e' ->
-> returnSUs (CoLet (CoNonRec id e) e')
->
-> CoLet (CoRec bs) e ->
->-- convRecBinds bs e `thenSUs` \(bs,e) ->
->-- returnSUs (CoLet (CoRec bs) e)
-> convExpr e `thenSUs` \e ->
-> mapSUs convRecBind bs `thenSUs` \bs ->
-> returnSUs (CoLet (CoRec bs) e)
+>
+> CoTyApp e ty ->
+> convExpr e `thenUs` \e ->
+> returnUs (CoTyApp e ty)
+>
+> Case e ps ->
+> convCaseAlts ps `thenUs` \ps ->
+> case e of
+> Var (DefArgVar id) | (not.deforestable) id ->
+> returnUs (Case e ps)
+> Prim op ts es -> returnUs (Case e ps)
+> _ -> d2c e `thenUs` \e' ->
+> newLet e (\v -> Case v ps)
+>
+> Let (NonRec id e) e' ->
+> convExpr e `thenUs` \e ->
+> convExpr e' `thenUs` \e' ->
+> returnUs (Let (NonRec id e) e')
+>
+> Let (Rec bs) e ->
+>-- convRecBinds bs e `thenUs` \(bs,e) ->
+>-- returnUs (Let (Rec bs) e)
+> convExpr e `thenUs` \e ->
+> mapUs convRecBind bs `thenUs` \bs ->
+> returnUs (Let (Rec bs) e)
> where
-> convRecBind (v,e) =
-> convExpr e `thenSUs` \e ->
-> returnSUs (v,e)
->
-> CoSCC l e ->
-> convExpr e `thenSUs` \e ->
-> returnSUs (CoSCC l e)
+> convRecBind (v,e) =
+> convExpr e `thenUs` \e ->
+> returnUs (v,e)
+>
+> SCC l e ->
+> convExpr e `thenUs` \e ->
+> returnUs (SCC l e)
Mark all the recursive functions as deforestable. Might as well,
since they will be in treeless form anyway. This helps to cope with
dictionary deconstruction.
> convRecBinds bs e =
-> convExpr e `thenSUs` \e' ->
-> mapSUs convExpr es `thenSUs` \es' ->
-> mapSUs (subst s) es' `thenSUs` \es'' ->
-> subst s e' `thenSUs` \e'' ->
-> returnSUs (zip vs' es', e')
+> convExpr e `thenUs` \e' ->
+> mapUs convExpr es `thenUs` \es' ->
+> mapUs (subst s) es' `thenUs` \es'' ->
+> subst s e' `thenUs` \e'' ->
+> returnUs (zip vs' es', e')
> where
> (vs,es) = unzip bs
> vs' = map mkDeforestable vs
-> s = zip vs (map (CoVar . DefArgVar) vs')
+> s = zip vs (map (Var . DefArgVar) vs')
> mkDeforestable v = replaceIdInfo v (addInfo (getIdInfo v) DoDeforest)
-> convAtom :: DefAtom -> SUniqSM DefAtom
->
-> convAtom (CoVarAtom v) =
-> convArg v `thenSUs` \v ->
-> returnSUs (CoVarAtom v)
-> convAtom (CoLitAtom l) =
-> returnSUs (CoLitAtom l) -- XXX
+> convAtom :: DefAtom -> UniqSM DefAtom
+>
+> convAtom (VarArg v) =
+> convArg v `thenUs` \v ->
+> returnUs (VarArg v)
+> convAtom (LitArg l) =
+> returnUs (LitArg l) -- XXX
-> convArg :: DefBindee -> SUniqSM DefBindee
->
+> convArg :: DefBindee -> UniqSM DefBindee
+>
> convArg (DefArgExpr e) =
-> convExpr e `thenSUs` \e ->
-> returnSUs (DefArgExpr e)
-> convArg e@(Label _ _) =
+> convExpr e `thenUs` \e ->
+> returnUs (DefArgExpr e)
+> convArg e@(Label _ _) =
> panic "TreelessForm(convArg): Label _ _"
> convArg e@(DefArgVar id) =
> panic "TreelessForm(convArg): DefArgVar _ _"
-> convCaseAlts :: DefCaseAlternatives -> SUniqSM DefCaseAlternatives
->
-> convCaseAlts (CoAlgAlts as def) =
-> mapSUs convAlgAlt as `thenSUs` \as ->
-> convDefault def `thenSUs` \def ->
-> returnSUs (CoAlgAlts as def)
-> convCaseAlts (CoPrimAlts as def) =
-> mapSUs convPrimAlt as `thenSUs` \as ->
-> convDefault def `thenSUs` \def ->
-> returnSUs (CoPrimAlts as def)
-
-> convAlgAlt (c, vs, e) =
-> convExpr e `thenSUs` \e ->
-> returnSUs (c, vs, e)
-> convPrimAlt (l, e) =
-> convExpr e `thenSUs` \e ->
-> returnSUs (l, e)
-
-> convDefault CoNoDefault =
-> returnSUs CoNoDefault
-> convDefault (CoBindDefault id e) =
-> convExpr e `thenSUs` \e ->
-> returnSUs (CoBindDefault id e)
-
-> newLet :: DefExpr -> (DefExpr -> DefExpr) -> SUniqSM DefExpr
-> newLet e body =
-> d2c e `thenSUs` \core_expr ->
-> newDefId (typeOfCoreExpr core_expr) `thenSUs` \new_id ->
-> returnSUs (CoLet (CoNonRec new_id e) (body (CoVar (DefArgVar new_id))))
+> convCaseAlts :: DefCaseAlternatives -> UniqSM DefCaseAlternatives
+>
+> convCaseAlts (AlgAlts as def) =
+> mapUs convAlgAlt as `thenUs` \as ->
+> convDefault def `thenUs` \def ->
+> returnUs (AlgAlts as def)
+> convCaseAlts (PrimAlts as def) =
+> mapUs convPrimAlt as `thenUs` \as ->
+> convDefault def `thenUs` \def ->
+> returnUs (PrimAlts as def)
+
+> convAlgAlt (c, vs, e) =
+> convExpr e `thenUs` \e ->
+> returnUs (c, vs, e)
+> convPrimAlt (l, e) =
+> convExpr e `thenUs` \e ->
+> returnUs (l, e)
+
+> convDefault NoDefault =
+> returnUs NoDefault
+> convDefault (BindDefault id e) =
+> convExpr e `thenUs` \e ->
+> returnUs (BindDefault id e)
+
+> newLet :: DefExpr -> (DefExpr -> DefExpr) -> UniqSM DefExpr
+> newLet e body =
+> d2c e `thenUs` \core_expr ->
+> newDefId (coreExprType core_expr) `thenUs` \new_id ->
+> returnUs (Let (NonRec new_id e) (body (Var (DefArgVar new_id))))
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CE where
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import Id(Id)
-import Maybes(MaybeErr)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import TyCon(TyCon)
-import UniqFM(UniqFM)
-import Unique(Unique)
-type CE = UniqFM Class
-data Class
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data MaybeErr a b
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data UniqFM a
-data Unique
-checkClassCycles :: UniqFM Class -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep)
-lookupCE :: UniqFM Class -> Name -> Class
-nullCE :: UniqFM Class
-plusCE :: UniqFM Class -> UniqFM Class -> UniqFM Class
-rngCE :: UniqFM Class -> [Class]
-unitCE :: Unique -> Class -> UniqFM Class
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[CE]{Class environment}
-
-\begin{code}
-#include "HsVersions.h"
-
-module CE (
- CE(..),
- nullCE, unitCE, rngCE,
- plusCE, lookupCE,
- checkClassCycles,
-
- -- imported things so we're self-contained...
- Unique, UniqFM,
- Class, MaybeErr, Name, Pretty(..), PprStyle,
- PrettyRep, Error(..)
-
- IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
- IF_ATTACK_PRAGMAS(COMMA eltsUFM COMMA singletonDirectlyUFM)
- IF_ATTACK_PRAGMAS(COMMA u2i)
- ) where
-
-import AbsUniType ( getClassSig, Class, ClassOp, TyCon, FullName, Arity(..)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- )
-import Digraph ( topologicalSort )
-import Errors -- notably classCycleErr
-import UniqFM -- basic environment handling
-import Maybes ( Maybe(..), MaybeErr(..) )
-import Name -- Name(..), etc.
-import Pretty
-import Outputable -- def of ppr
-import Unique -- for ClassKey uniques
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-%* The main representation *
-%* *
-%************************************************************************
-
-\begin{code}
---data CE = MkCE (FiniteMap Unique Class) -- keyed off Class's Uniques
-type CE = UniqFM Class
-#define MkCE {--}
--- also killed instance CE, exported non-abstractly
-
-nullCE :: CE
-nullCE = MkCE emptyUFM
-
-rngCE :: CE -> [Class]
-rngCE (MkCE env) = eltsUFM env
-
-unitCE :: Unique{-ClassKey-} -> Class -> CE
-unitCE u c = MkCE (singletonDirectlyUFM u c)
-
-plusCE :: CE -> CE -> CE
-plusCE (MkCE ce1) (MkCE ce2) = MkCE (plusUFM ce1 ce2)
-
-lookupCE :: CE -> Name -> Class
-lookupCE (MkCE ce) name
- = case name of
- PreludeClass key _ -> case (lookupDirectlyUFM ce key) of
- Just clas -> clas
- Nothing -> err_msg
- OtherClass uniq _ _ -> case (lookupDirectlyUFM ce uniq) of
- Just clas -> clas
- Nothing -> panic "lookupCE! (non-prelude)"
- where
- err_msg = error ("ERROR: in looking up a Prelude class! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)\n")
-
-checkClassCycles :: CE -> MaybeErr () Error
-checkClassCycles (MkCE stuff)
- = case (topologicalSort (==) edges classes) of
- Succeeded _ -> Succeeded ()
- Failed cycles
- -> Failed (classCycleErr [ map fmt_tycon c | c <- cycles ])
- where
- fmt_tycon c = (ppr PprForUser c, getSrcLoc c)
- where
- classes = eltsUFM stuff -- the "vertices"
- edges = concat (map get_edges classes)
-
- get_edges clas
- = let (_, super_classes, _) = getClassSig clas in
- [ (clas, super_class) | super_class <- super_classes ]
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface E where
-import CE(CE(..))
-import Class(Class)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import TCE(TCE(..))
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniqFM(UniqFM)
-import Unique(Unique)
-type CE = UniqFM Class
-data E
-type GVE = [(Name, Id)]
-data Id
-type LVE = [(Name, Id)]
-data Labda a
-data Name
-type TCE = UniqFM TyCon
-data TyVar
-data UniqFM a
-getE_CE :: E -> UniqFM Class
-getE_GlobalVals :: E -> [Id]
-getE_TCE :: E -> UniqFM TyCon
-growE_LVE :: E -> [(Name, Id)] -> E
-lookupE_Binder :: E -> Name -> Id
-lookupE_ClassOpByKey :: E -> Unique -> _PackedString -> Id
-lookupE_Value :: E -> Name -> Id
-lookupE_ValueQuietly :: E -> Name -> Labda Id
-mkE :: UniqFM TyCon -> UniqFM Class -> E
-nullE :: E
-nullGVE :: [(Name, Id)]
-nullLVE :: [(Name, Id)]
-plusE_CE :: E -> UniqFM Class -> E
-plusE_GVE :: E -> [(Name, Id)] -> E
-plusE_TCE :: E -> UniqFM TyCon -> E
-plusGVE :: [a] -> [a] -> [a]
-plusLVE :: [a] -> [a] -> [a]
-tvOfE :: E -> [TyVar]
-unitGVE :: Name -> Id -> [(Name, Id)]
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[E]{Main typechecker environment}
-
-\begin{code}
-#include "HsVersions.h"
-
-module E (
- E,
- mkE, nullE,
- getE_GlobalVals, getE_TCE, getE_CE,
- plusE_TCE, plusE_CE,
-
- growE_LVE, plusE_GVE, tvOfE,
-
- lookupE_Value, lookupE_ValueQuietly,
- lookupE_ClassOpByKey, lookupE_Binder,
-
- GVE(..), LVE(..),
- plusLVE, nullLVE,
- plusGVE, nullGVE, unitGVE, -- UNUSED: rngGVE,
-
- -- and to make the interface self-sufficient...
- CE(..), Id, Name, TCE(..), TyVar, Maybe, UniqFM
- ) where
-
-import CE
-import TCE
-import UniqFM -- basic env handling code
-
-import AbsPrel ( PrimOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType ( getClassOps, extractTyVarsFromTy,
- getClassBigSig, getClassOpString, TyVar,
- TyVarTemplate, ClassOp, Class, Arity(..),
- TauType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar COMMA cmpClass)
- )
-import Id ( getIdUniType, Id, IdInfo )
-import Maybes ( MaybeErr(..), Maybe(..) )
-import Name -- Name(..), etc.
-import Outputable -- def of ppr, etc.
-import Pretty -- to pretty-print error messages
-import UniqSet -- this use of Sets is a HACK (WDP 94/05)
-import Unique -- *Key stuff
-import Util
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Type declarations}
-%* *
-%************************************************************************
-
-
-\begin{code}
-data E
- = MkE TCE -- type environment
- GVB -- "global" value bindings; no free type vars
- LVB -- "local" value bindings; may have free type vars
- CE -- class environment
-
-mkE :: TCE -> CE -> E
-mkE tce ce = MkE tce nullGVB nullLVB ce
-
-nullE :: E
-nullE = MkE nullTCE nullGVB nullLVB nullCE
-\end{code}
-
-The ``local'' and ``global'' bindings, @LVB@ and @GVB@, are
-non-exported synonyms. The important thing is that @GVB@ doesn't
-contain any free type variables. This is used (only) in @tvOfE@,
-which extracts free type variables from the environment. It's quite a
-help to have this separation because there may be quite a large bunch
-of imported things in the @GVB@, all of which are guaranteed
-polymorphic.
-
-\begin{code}
-type LVB = UniqFM Id -- Locals just have a Unique
-type GVB = UniqFM Id -- Globals might be a prelude thing; hence IdKey
-
-nullLVB = (emptyUFM :: LVB)
-nullGVB = (emptyUFM :: GVB)
-\end{code}
-
-The ``local'' and ``global'' value environments are not part of @E@ at
-all, but is used to provide increments to the value bindings. GVE are
-carries the implication that there are no free type variables.
-
-\begin{code}
-type LVE = [(Name, Id)] -- Maps Names to Ids
-type GVE = [(Name, Id)] -- Maps Names to Ids
-
-nullLVE = ([] :: LVE)
-plusLVE a b = a ++ b
-nullGVE = ([] :: GVE)
-unitGVE n i = ( [(n, i)] :: GVE )
--- UNUSED: rngGVE gve = map snd gve
-plusGVE a b = a ++ b
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Value environment stuff}
-%* *
-%************************************************************************
-
-Looking up things should mostly succeed, because the renamer should
-have spotted all out-of-scope names. The exception is instances.
-
-The ``Quietly'' version is for pragmas, where lookups very well may
-fail. @lookup_val@ is the internal function that does the work.
-
-\begin{code}
-lookupE_Value :: E -> Name -> Id
-lookupE_ValueQuietly :: E -> Name -> Maybe Id
-
-lookupE_Value e nm
- = case lookup_val e nm of
- Succeeded id -> id
- Failed (should_panic, msg)
- -> if should_panic then panic msg else error msg
-
-lookupE_ValueQuietly e nm
- = case lookup_val e nm of
- Succeeded id -> Just id
- Failed _ -> Nothing
-\end{code}
-
-\begin{code}
-lookup_val (MkE _ gvb lvb ce) name
- = case name of
-
- WiredInVal id -> Succeeded id
- PreludeVal key _ -> case (lookupDirectlyUFM gvb key) of
- Just id -> Succeeded id
- Nothing -> Failed (False, prelude_err_msg)
-
- ClassOpName uniq clas_name _ tag -> id_from_env uniq
-
- -- You might think that top-level ids are guaranteed to have no
- -- free tyvars, so look only in gvb; but you'd be wrong! When
- -- type-checking the RHS of recursive top-level defns, the name
- -- of the thing is bound to a *monomorphic* type, which is later
- -- generalised. So we have to look in the LVE too.
-
- OtherTopId uniq _ -> id_from_env uniq
-
- -- Short names could be in either GVB or LVB
- Short uniq _ -> id_from_env uniq
-
- funny_name -> pprPanic "lookup_val: funny Name" (ppr PprDebug funny_name)
- where
- prelude_err_msg = "ERROR: in looking up a built-in Prelude value!\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)"
-
- id_from_env uniq
- = case (lookupDirectlyUFM lvb uniq) of
- Just id -> Succeeded id
- Nothing ->
- case (lookupDirectlyUFM gvb uniq) of
- Just id -> Succeeded id
- Nothing -> Failed (True, -- should panic
- ("lookupE_Value: unbound name: "++(ppShow 80 (ppr PprShowAll name))))
-\end{code}
-
-For Prelude things that we reach out and grab, we have only an @Unique@.
-\begin{code}
-lookupE_ClassOpByKey :: E -> Unique{-ClassKey-} -> FAST_STRING -> Id
-
-lookupE_ClassOpByKey (MkE _ gvb lvb ce) clas_key op_str
- = let
- clas = lookupCE ce (PreludeClass clas_key bottom)
- bottom = pprPanic ("lookupE_ClassOpByKey: "++(_UNPK_ op_str))
- (ppAbove (pprUnique clas_key) (ppr PprShowAll (rngCE ce)))
-
- (clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
- = getClassBigSig clas
- in
- case [ op_sel_id | (op, op_sel_id) <- ops `zip` op_sel_ids,
- op_str == getClassOpString op ] of
- [op] -> op
- -- Seems a rather horrible way to do it (ToDo)
-\end{code}
-
-@lookupE_Binder@ is like @lookupE_Value@, but it is used for {\em
-binding} occurrences of a variable, rather than {\em uses}. The
-difference is that there should always be an entry in the LVE for
-binding occurrences. Just a sanity check now, really.
-
-\begin{code}
-lookupE_Binder :: E -> Name -> Id
-lookupE_Binder (MkE _ _ lvb _) name
- = case (lookupDirectlyUFM lvb (name2uniq name)) of
- Just id -> id
- Nothing -> pprPanic "lookupE_Binder: unbound name: " (ppr PprShowAll name)
-\end{code}
-
-\begin{code}
-getE_GlobalVals :: E -> [Id]
-getE_GlobalVals (MkE tce gvb lvb ce)
- = let
- result = eltsUFM gvb ++ eltsUFM lvb
- in
- -- pprTrace "Global Ids:" (ppr PprShowAll result)
- result
-
-plusE_GVE :: E -> GVE -> E
-plusE_GVE (MkE tce gvb lvb ce) gve
- = let
- new_stuff = listToUFM_Directly [(name2idkey n, i) | (n,i) <- gve ]
- in
- MkE tce (plusUFM gvb new_stuff) lvb ce
- where
- name2idkey (PreludeVal k _) = k
- name2idkey (OtherTopId u _) = u
- name2idkey (ClassOpName u _ _ _) = u
-
-growE_LVE :: E -> LVE -> E
-growE_LVE (MkE tce gvb lvb ce) lve
- = let
- new_stuff = listToUFM_Directly [(name2uniq n, i) | (n,i) <- lve ]
- in
- MkE tce gvb (plusUFM lvb new_stuff) ce
-
--- ToDo: move this elsewhere??
-name2uniq (Short u _) = u
-name2uniq (OtherTopId u _) = u
-name2uniq (ClassOpName u _ _ _) = panic "growE_LVE:name2uniq"
-\end{code}
-
-Return the free type variables of an LVE; there are no duplicates in
-the result---hence all the @Set@ bozo-ery. The free tyvars can only
-occur in the LVB part.
-
-\begin{code}
-tvOfE :: E -> [TyVar]
-tvOfE (MkE tce gvb lvb ce)
- = uniqSetToList (mkUniqSet (
- foldr ((++) . extractTyVarsFromTy . getIdUniType) [] (eltsUFM lvb)
- ))
-\end{code}
-
-%************************************************************************
-%* *
-%*
-\subsection{Type and class environments}
-%* *
-%************************************************************************
-
-\begin{code}
-getE_TCE :: E -> TCE
-getE_TCE (MkE tce gvb lvb ce) = tce
-
-getE_CE :: E -> CE
-getE_CE (MkE tce gvb lvb ce) = ce
-
-plusE_TCE :: E -> TCE -> E
-plusE_TCE (MkE tce gvb lvb ce) tce'
- = MkE (plusTCE tce' tce) gvb lvb ce
-
-plusE_CE :: E -> CE -> E
-plusE_CE (MkE tce gvb lvb ce) ce'
- = MkE tce gvb lvb (plusCE ce ce')
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface IdEnv where
-import Id(Id)
-import Maybes(Labda(..))
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Id
-type IdEnv a = UniqFM a
-data Labda a = Hamna | Ni a
-data UniqFM a
-data Unique
-addOneToIdEnv :: UniqFM a -> Id -> a -> UniqFM a
-combineIdEnvs :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
-delManyFromIdEnv :: UniqFM a -> [Id] -> UniqFM a
-delOneFromIdEnv :: UniqFM a -> Id -> UniqFM a
-growIdEnv :: UniqFM a -> UniqFM a -> UniqFM a
-growIdEnvList :: UniqFM a -> [(Id, a)] -> UniqFM a
-isNullIdEnv :: UniqFM a -> Bool
-lookupIdEnv :: UniqFM a -> Id -> Labda a
-lookupNoFailIdEnv :: UniqFM a -> Id -> a
-mapIdEnv :: (a -> b) -> UniqFM a -> UniqFM b
-mkIdEnv :: [(Id, a)] -> UniqFM a
-modifyIdEnv :: UniqFM a -> (a -> a) -> Id -> UniqFM a
-nullIdEnv :: UniqFM a
-rngIdEnv :: UniqFM a -> [a]
-unitIdEnv :: Id -> a -> UniqFM a
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1995
-%
-\section[IdEnv]{Lookup tables that have @Id@ keys}
-
-An interface to the @FiniteMap@ machinery, which exports
-a ``personality'' the same as that of the old @IdEnv@ module.
-
-\begin{code}
-#include "HsVersions.h"
-
-module IdEnv (
- IdEnv(..), -- abstract: NOT
-
- lookupIdEnv, lookupNoFailIdEnv,
- nullIdEnv, unitIdEnv, mkIdEnv, growIdEnv, growIdEnvList,
- isNullIdEnv,
- addOneToIdEnv,
- delOneFromIdEnv, delManyFromIdEnv, --UNUSED: minusIdEnv,
- modifyIdEnv, combineIdEnvs,
- rngIdEnv,
- mapIdEnv,
--- UNUSED: filterIdEnv,
-
- -- and to make the interface self-sufficient...
- UniqFM,
- Id, Unique, Maybe(..)
-
- -- and for pragma-friendliness...
-#ifdef USE_ATTACK_PRAGMAS
- , addToUFM, plusUFM_C, delListFromUFM, delFromUFM, plusUFM,
- lookupUFM, mapUFM, filterUFM, minusUFM, listToUFM, emptyUFM,
- eltsUFM, singletonUFM,
- u2i
-#endif
- ) where
-
-import UniqFM
-import Id
-import IdInfo
-import Maybes ( Maybe(..), MaybeErr(..) )
-import Outputable
-import Unique ( Unique, u2i )
-import Util
-\end{code}
-
-\begin{code}
-type IdEnv elt = UniqFM elt
-\end{code}
-
-Signatures:
-\begin{code}
-addOneToIdEnv :: IdEnv a -> Id -> a -> IdEnv a
-combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
-delManyFromIdEnv :: IdEnv a -> [Id] -> IdEnv a
-delOneFromIdEnv :: IdEnv a -> Id -> IdEnv a
-growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
-growIdEnvList :: IdEnv a -> [(Id, a)] -> IdEnv a
-isNullIdEnv :: IdEnv a -> Bool
-lookupIdEnv :: IdEnv a -> Id -> Maybe a
-lookupNoFailIdEnv :: IdEnv a -> Id -> a
-mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
---filterIdEnv :: (a -> Bool) -> IdEnv a -> IdEnv a
---minusIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
-mkIdEnv :: [(Id, a)] -> IdEnv a
-modifyIdEnv :: IdEnv a -> (a -> a) -> Id -> IdEnv a
-nullIdEnv :: IdEnv a
-rngIdEnv :: IdEnv a -> [a]
-unitIdEnv :: Id -> a -> IdEnv a
-\end{code}
-
-\begin{code}
-addOneToIdEnv env id elt = addToUFM env id elt
-
-combineIdEnvs combiner env1 env2 = plusUFM_C combiner env1 env2
-
-delManyFromIdEnv env ids = delListFromUFM env ids
-
-delOneFromIdEnv env id = delFromUFM env id
-
-growIdEnv old_env new_stuff = plusUFM old_env new_stuff
-
-growIdEnvList old_env pairs = plusUFM old_env (listToUFM pairs)
-
-isNullIdEnv env = sizeUFM env == 0
-
-lookupIdEnv env id = lookupUFM env id
-
-lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
-
-mapIdEnv f env = mapUFM f env
-
-{- UNUSED:
-filterIdEnv p env = filterUFM p env
-minusIdEnv env1 env2 = minusUFM env1 env2
--}
-
-mkIdEnv stuff = listToUFM stuff
-
--- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
--- modify function, and put it back.
-
-modifyIdEnv env mangle_fn key
- = case (lookupIdEnv env key) of
- Nothing -> env
- Just xx -> addOneToIdEnv env key (mangle_fn xx)
-
-nullIdEnv = emptyUFM
-
-rngIdEnv env = eltsUFM env
-
-unitIdEnv id elt = singletonUFM id elt
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface InstEnv where
-import BasicLit(BasicLit)
-import Class(Class, ClassOp)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import HsBinds(Binds)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(InPat, TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import IdInfo(SpecEnv, SpecInfo)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import Maybes(Labda, MaybeErr)
-import Name(Name)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique)
-data Class
-type ClassInstEnv = [(UniType, InstTemplate)]
-data ClassOp
-data CoreExpr a b
-data Expr a b
-data Id
-data Inst
-data InstOrigin
-data InstTemplate
-data InstTy
-type InstanceMapper = Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)
-data Labda a
-type MatchEnv a b = [(a, b)]
-data MaybeErr a b
-type MethodInstInfo = (Id, [UniType], InstTemplate)
-data TypecheckedPat
-data SpecEnv
-data SpecInfo
-data SplitUniqSupply
-data TyCon
-data TyVarTemplate
-data UniType
-addClassInst :: Class -> [(UniType, InstTemplate)] -> UniType -> Id -> [TyVarTemplate] -> [(Class, UniType)] -> SrcLoc -> MaybeErr [(UniType, InstTemplate)] (Class, (UniType, SrcLoc), (UniType, SrcLoc))
-lookupClassInstAtSimpleType :: Class -> UniType -> Labda Id
-lookupInst :: SplitUniqSupply -> Inst -> Labda (Expr Id TypecheckedPat, [Inst])
-lookupNoBindInst :: SplitUniqSupply -> Inst -> Labda [Inst]
-mkInstSpecEnv :: Class -> UniType -> [TyVarTemplate] -> [(Class, UniType)] -> SpecEnv
-nullMEnv :: [(a, b)]
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
-%
-\section[InstEnv]{Instance environments}
-
-\begin{code}
-#include "HsVersions.h"
-
-module InstEnv (
- -- these types could use some abstractification (??? ToDo)
- ClassInstEnv(..), -- OLD: IdInstEnv(..),
- InstTemplate, InstTy,
- MethodInstInfo(..), -- needs to be exported? (ToDo)
- InstanceMapper(..), -- widely-used synonym
-
--- instMethod, instTemplate, -- no need to export
- addClassInst, {- NOT USED addConstMethInst, -}
- lookupInst,
- lookupClassInstAtSimpleType,
- lookupNoBindInst,
- mkInstSpecEnv,
-
- MatchEnv(..), -- mk more abstract (??? ToDo)
- nullMEnv,
--- mkMEnv, lookupMEnv, matchMEnv, insertMEnv, -- no need to export
-
- -- and to make the interface self-sufficient...
- Class, ClassOp, CoreExpr, Expr, TypecheckedPat, Id,
- Inst, InstOrigin, Maybe, MaybeErr, TyVarTemplate, TyCon,
- UniType, SplitUniqSupply, SpecInfo, SpecEnv
- ) where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-
-import AbsPrel ( intTyCon, --wordTyCon, addrTyCon,
- floatTyCon, doubleTyCon, charDataCon, intDataCon,
- wordDataCon, addrDataCon, floatDataCon,
- doubleDataCon,
- intPrimTyCon, doublePrimTyCon
- )
-import AbsSyn -- TypecheckedExpr, etc.
-import AbsUniType
-import Id
-import IdInfo
-import Inst
-import Maybes -- most of it
-import Outputable ( isExported )
-import PlainCore -- PlainCoreExpr, etc.
-import Pretty
-import PrimKind -- rather grubby import (ToDo?)
-import SplitUniq
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[InstEnv-types]{Type declarations}
-%* *
-%************************************************************************
-
-\begin{code}
-type InstanceMapper
- = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
-
-type ClassInstEnv
- = MatchEnv UniType InstTemplate -- Instances of dicts
-
-data InstTemplate
- = MkInstTemplate
- Id -- A fully polymorphic Id; it is the function
- -- which produces the Id instance or dict from
- -- the pieces specified by the rest of the
- -- template. Its SrcLoc tells where the
- -- instance was defined.
- [UniType] -- Apply it to these types, suitably instantiated
- [InstTy] -- and instances of these things
-
-type MethodInstInfo = (Id, [UniType], InstTemplate) -- Specifies a method instance
-\end{code}
-
-There is an important consistency constraint between the @MatchEnv@s
-in and the @InstTemplate@s inside them: the @UniType@(s) which is/are
-the key for the @MatchEnv@ must contain only @TyVarTemplates@, and
-these must be a superset of the @TyVarTemplates@ mentioned in the
-corresponding @InstTemplate@.
-
-Reason: the lookup process matches the key against the desired value,
-returning a substitution which is used to instantiate the template.
-
-\begin{code}
-data InstTy
- = DictTy Class UniType
- | MethodTy Id [UniType]
-\end{code}
-
- MkInstTemplate f tvs insts
-
-says that, given a particular mapping of type variables tvs to some
-types tys, the value which is the required instance is
-
- f tys (insts [tys/tvs])
-
-
-@instMethod@ is used if there is no instance for a method; then it is
-expressed in terms of the corresponding dictionary (or possibly, in a
-wired-in case only, dictionaries).
-
-\begin{code}
-instMethod :: SplitUniqSupply
- -> InstOrigin
- -> Id -> [UniType]
- -> (TypecheckedExpr, [Inst])
-
-instMethod uniqs orig id tys
- = (mkDictApp (mkTyApp (Var id) tys) dicts,
- insts)
- where
- (tyvars, theta, tau_ty) = splitType (getIdUniType id)
- tenv = tyvars `zipEqual` tys
- insts = mk_dict_insts uniqs theta
- dicts = map mkInstId insts
-
- mk_dict_insts us [] = []
- mk_dict_insts us ((clas, ty) : rest)
- = case splitUniqSupply us of { (s1, s2) ->
- (Dict (getSUnique s1) clas (instantiateTauTy tenv ty) orig)
- : mk_dict_insts s2 rest
- }
-\end{code}
-
-@instTemplate@ is used if there is an instance for a method or dictionary.
-
-\begin{code}
-instTemplate :: SplitUniqSupply
- -> InstOrigin
- -> [(TyVarTemplate, UniType)]
- -> InstTemplate
- -> (TypecheckedExpr, [Inst])
-
-instTemplate uniqs orig tenv (MkInstTemplate id ty_tmpls inst_tys)
- = (mkDictApp (mkTyApp (Var id) ty_args) ids, -- ToDo: not strictly a dict app
- -- for Method inst_tys
- insts)
- where
- ty_args = map (instantiateTy tenv) ty_tmpls
- insts = mk_insts uniqs inst_tys
- ids = map mkInstId insts
-
- mk_insts us [] = []
- mk_insts us (inst_ty : rest)
- = case splitUniqSupply us of { (s1, s2) ->
- let
- uniq = getSUnique s1
- in
- (case inst_ty of
- DictTy clas ty -> Dict uniq clas (instantiateTy tenv ty) orig
- MethodTy id tys -> Method uniq id (map (instantiateTy tenv) tys) orig
- ) : mk_insts s2 rest
- }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[InstEnv-adding]{Adding new class instances}
-%* *
-%************************************************************************
-
-@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ based on
-information from a single instance declaration. It complains about
-any overlap with an existing instance.
-
-Notice that we manufacture the @DictFunId@ and @ConstMethodId@s from
-scratch here, rather than passing them in. This means a small amount
-of duplication (no big deal) and that we can't attach a single
-canonical unfolding; but they don't have a slot for unfoldings
-anyway... This could be improved. (We do, however, snaffle in the
-pragma info from the interface...)
-
-{\em Random notes}
-
-\begin{verbatim}
-class Foo a where
- fop :: Ord b => a -> b -> b -> a
-
-instance Foo Int where
- fop x y z = if y<z then x else fop x z y
-
-instance Foo a => Foo [a] where
- fop [] y z = []
- fop (x:xs) y z = [fop x y z]
-\end{verbatim}
-
-
-For the Int instance we add to the ??? envt
-\begin{verbatim}
- (ClassOpId Foo fop) |--> [Int,b] |--> InstTemplate (ConstMethodId Foo fop Int) [b] [Ord b]
-\end{verbatim}
-
-If there are no type variables, @addClassInstance@ adds constant
-instances for those class ops not mentioned in the class-op details
-(possibly using the pragma info that was passed in). This MUST
-be the same decision as that by @tcInstDecls2@ about whether to
-generate constant methods. NB: A slightly more permissive version
-would base the decision on the context being empty, but there is
-slightly more admin associated and the benefits are very slight; the
-context is seldom empty unless there are no tyvars involved.
-
-Note: the way of specifying class-op instance details is INADEQUATE
-for polymorphic class ops. That just means you can't specify clever
-instances for them via this function.
-
-\begin{code}
-addClassInst
- :: Class -- class in question (for err msg only)
- -> ClassInstEnv -- Incoming envt
- -> UniType -- The instance type
- -> Id -- Dict fun id to apply
- -> [TyVarTemplate] -- Types to which (after instantiation) to apply the dfun
- -> ThetaType -- Dicts to which to apply the dfun
- -> SrcLoc -- associated SrcLoc (for err msg only)
- -> MaybeErr
- ClassInstEnv -- Success
- (Class, (UniType, SrcLoc), -- Failure: the overlapping pair
- (UniType, SrcLoc))
-
-addClassInst clas inst_env inst_ty dfun_id inst_tyvars dfun_theta locn
- = case (insertMEnv matchTy inst_env inst_ty dict_template) of
- Succeeded inst_env' -> Succeeded inst_env'
- Failed (ty', MkInstTemplate id' _ _)
- -> Failed (clas, (inst_ty, locn), (ty', getSrcLoc id'))
- where
- dict_template = MkInstTemplate dfun_id
- (map mkTyVarTemplateTy inst_tyvars)
- (unzipWith DictTy dfun_theta)
-\end{code}
-
-============ NOT USED =============
-@addConstMethInst@ panics on overlap, because @addClassInst@ has already found
-any overlap.
-
-\begin{pseudocode}
-addConstMethInst :: IdInstEnv
- -> UniType -- The instance type
- -> Id -- The constant method
- -> [TyVarTemplate] -- Apply method to these (as above)
- -> IdInstEnv
-
-addConstMethInst inst_env inst_ty meth_id inst_tyvars
- = case (insertMEnv matchTys inst_env [inst_ty] template) of
- Succeeded inst_env' -> inst_env'
- Failed (tys', MkInstTemplate id' _ _) ->
- pprPanic "addConstMethInst:"
- (ppSep [ppr PprDebug meth_id,
- ppr PprDebug inst_ty,
- ppr PprDebug id'])
- where
- template = MkInstTemplate meth_id (map mkTyVarTemplateTy inst_tyvars) []
- -- Constant method just needs to be applied to tyvars
- -- (which are usually empty)
-\end{pseudocode}
-
-@mkIdInstEnv@ is useful in the simple case where we've a list of
-@(types, id)@ pairs; the \tr{id} is the \tr{types} specialisation of
-some other Id (in which the resulting IdInstEnv will doubtless be
-embedded. There's no messing about with type variables or
-dictionaries here.
-
-\begin{code}
-{- OLD:
-mkIdInstEnv :: [([TauType],Id)] -> IdInstEnv
-
-mkIdInstEnv [] = nullMEnv
-mkIdInstEnv ((tys,id) : rest)
- = let
- inst_env = mkIdInstEnv rest
- in
- case (insertMEnv matchTys inst_env tys template) of
- Succeeded inst_env' -> inst_env'
- Failed _ -> panic "Failed in mkIdInstEnv"
- where
- template = MkInstTemplate id [] []
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[InstEnv-lookup]{Performing lookup}
-%* *
-%************************************************************************
-
-\begin{code}
-lookupInst :: SplitUniqSupply
- -> Inst
- -> Maybe (TypecheckedExpr,
- [Inst])
-
-lookupInst uniqs (Dict _ clas ty orig)
- = if isTyVarTy ty then
- Nothing -- No instances of a class at a type variable
- else
- case (lookupMEnv matchTy inst_env ty) of
- Nothing -> Nothing
- Just (_,tenv,templ) -> Just (instTemplate uniqs orig tenv templ)
- where
- inst_env
- = case orig of
-
- -- During deriving and instance specialisation operations
- -- we can't get the instances of the class from inside the
- -- class, because the latter ain't ready yet. Instead we
- -- find a mapping from classes to envts inside the dict origin.
- -- (A Simon hack [WDP])
-
- DerivingOrigin inst_mapper _ _ _ _ -> fst (inst_mapper clas)
-
- InstanceSpecOrigin inst_mapper _ _ _ -> fst (inst_mapper clas)
-
- -- Usually we just get the instances of the class from
- -- inside the class itself.
-
- other -> getClassInstEnv clas
-
-lookupInst uniqs (Method _ id tys orig)
- = if (all isTyVarTy tys) then
- general_case -- Instance types are all type variables, so there can't be
- -- a special instance for this method
-
- else -- Get the inst env from the Id, and look up in it
- case (lookupSpecEnv (getIdSpecialisation id) tys) of
- Nothing -> general_case
- Just (spec_id, types_left, num_dicts_to_toss)
- -> Just (instMethod uniqs orig spec_id types_left)
- where
- general_case = Just (instMethod uniqs orig id tys)
-\end{code}
-
-Now "overloaded" literals: the plain truth is that the compiler
-is intimately familiar w/ the types Int, Integer, Float, and Double;
-for everything else, we actually conjure up an appropriately-applied
-fromInteger/fromRational, as the Haskell report suggests.
-
-\begin{code}
-lookupInst uniqs (LitInst u (OverloadedIntegral i from_int from_integer) ty orig)
- = Just (
- case (getUniDataTyCon_maybe ty) of -- this way is *unflummoxed* by synonyms
- Just (tycon, [], _)
- | tycon == intPrimTyCon -> (intprim_lit, [])
- | tycon == doublePrimTyCon -> (doubleprim_lit, [])
- | tycon == intTyCon -> (int_lit, [])
- | tycon == doubleTyCon -> (double_lit, [])
- | tycon == floatTyCon -> (float_lit, [])
--- | tycon == wordTyCon -> (word_lit, [])
--- | tycon == addrTyCon -> (addr_lit, [])
-
- _{-otherwise-} ->
-
- if (i >= toInteger minInt && i <= toInteger maxInt) then
- -- It's overloaded but small enough to fit into an Int
-
- let u2 = getSUnique uniqs
- method = Method u2 from_int [ty] orig
- in
- (App (Var (mkInstId method)) int_lit, [method])
-
- else
- -- Alas, it is overloaded and a big literal!
-
- let u2 = getSUnique uniqs
- method = Method u2 from_integer [ty] orig
- in
- (App (Var (mkInstId method)) (Lit (IntLit i)), [method])
- )
- where
-#if __GLASGOW_HASKELL__ <= 22
- iD = ((fromInteger i) :: Double)
-#else
- iD = ((fromInteger i) :: Rational)
-#endif
- intprim_lit = Lit (IntPrimLit i)
- doubleprim_lit = Lit (DoublePrimLit iD)
- int_lit = App (Var intDataCon) intprim_lit
- double_lit = App (Var doubleDataCon) doubleprim_lit
- float_lit = App (Var floatDataCon) (Lit (FloatPrimLit iD))
--- word_lit = App (Var wordDataCon) intprim_lit
--- addr_lit = App (Var addrDataCon) intprim_lit
-
-lookupInst uniqs (LitInst u (OverloadedFractional f from_rational) ty orig)
- = Just (
- case (getUniDataTyCon_maybe ty) of -- this way is *unflummoxed* by synonyms
- Just (tycon, [], _)
- | tycon == doublePrimTyCon -> (doubleprim_lit, [])
- | tycon == doubleTyCon -> (double_lit, [])
- | tycon == floatTyCon -> (float_lit, [])
-
- _ {-otherwise-} -> -- gotta fromRational it...
- --pprTrace "lookupInst:fractional lit ty?:" (ppr PprDebug ty) (
- let
- u2 = getSUnique uniqs
- method = Method u2 from_rational [ty] orig
- in
- (App (Var (mkInstId method)) (Lit (FracLit f)), [method])
- --)
- )
- where
-#if __GLASGOW_HASKELL__ <= 22
- fD = ((fromRational f) :: Double)
-#else
- fD = f
-#endif
- doubleprim_lit = Lit (DoublePrimLit fD)
- double_lit = App (Var doubleDataCon) doubleprim_lit
- float_lit = App (Var floatDataCon) (Lit (FloatPrimLit fD))
-\end{code}
-
-There is a second, simpler interface, when you want an instance of a
-class at a given nullary type constructor. It just returns the
-appropriate dictionary if it exists. It is used only when resolving
-ambiguous dictionaries.
-
-\begin{code}
-lookupClassInstAtSimpleType :: Class -> UniType -> Maybe Id
-
-lookupClassInstAtSimpleType clas ty
- = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
- Nothing -> Nothing
- Just (_,_,MkInstTemplate dict [] []) -> Just dict
-\end{code}
-
-Notice in the above that the type constructors in the default list
-should all have arity zero, so there should be no type variables
-or thetas in the instance declaration.
-
-There's yet a third interface for Insts which need no binding.
-They are used to record constraints on type variables, notably
-for CCall arguments and results.
-
-\begin{code}
-lookupNoBindInst :: SplitUniqSupply
- -> Inst
- -> Maybe [Inst]
-
-lookupNoBindInst uniqs (Dict _ clas ty orig)
- = if isTyVarTy ty then
- Nothing -- No instances of a class at a type variable
- else
- case (lookupMEnv matchTy inst_env ty) of
- Nothing -> Nothing
- Just (_,tenv,templ) ->
- case (instTemplate uniqs orig tenv templ) of
- (bottom_rhs, insts)
- -> Just insts
- -- The idea here is that the expression built by
- -- instTemplate isn't relevant; indeed, it might well
- -- be a place-holder bottom value.
- where
- inst_env = getClassInstEnv clas
-\end{code}
-
-\begin{code}
-mkInstSpecEnv :: Class -- class
- -> UniType -- instance type
- -> [TyVarTemplate] -- instance tyvars
- -> ThetaType -- superclasses dicts
- -> SpecEnv -- specenv for dfun of instance
-
-mkInstSpecEnv clas inst_ty inst_tvs inst_theta
- = mkSpecEnv (catMaybes (map maybe_spec_info matches))
- where
- matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty
-
- maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
- = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
- maybe_spec_info (_, match_info, _)
- = Nothing
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[MatchEnv]{Matching environments}
-%* *
-%************************************************************************
-
-``Matching'' environments allow you to bind a template to a value;
-when you look up in it, you supply a value which is matched against
-the template.
-
-\begin{code}
-type MatchEnv key value = [(key, value)]
-\end{code}
-
-For now we just use association lists. The list is maintained sorted
-in order of {\em decreasing specificness} of @key@, so that the first
-match will be the most specific.
-
-\begin{code}
-nullMEnv :: MatchEnv a b
-nullMEnv = []
-
-mkMEnv :: [(key, value)] -> MatchEnv key value
-mkMEnv stuff = stuff
-\end{code}
-
-@lookupMEnv@ looks up in a @MatchEnv@.
-It simply takes the first match, should be the most specific.
-
-\begin{code}
-lookupMEnv :: (key {- template -} -> -- Matching function
- key {- instance -} ->
- Maybe match_info)
- -> MatchEnv key value -- The envt
- -> key -- Key
- -> Maybe (key, -- Template
- match_info, -- Match info returned by matching fn
- value) -- Value
-
-lookupMEnv key_match alist key
- = find alist
- where
- find [] = Nothing
- find ((tpl, val) : rest)
- = case key_match tpl key of
- Nothing -> find rest
- Just match_info -> Just (tpl, match_info, val)
-\end{code}
-
-@matchEnv@ returns all more specidfic matches in a @MatchEnv@,
-most specific first.
-
-\begin{code}
-matchMEnv :: (key {- template -} -> -- Matching function
- key {- instance -} ->
- Maybe match_info)
- -> MatchEnv key value -- The envt
- -> key -- Key
- -> [(key,
- match_info, -- Match info returned by matching fn
- value)] -- Value
-
-matchMEnv key_match alist key
- = match alist
- where
- match [] = []
- match ((tpl, val) : rest)
- = case key_match tpl key of
- Nothing -> case key_match key tpl of
- Nothing -> match rest
- Just match_info -> (tpl, match_info, val) : match rest
- Just _ -> []
-\end{code}
-
-@insertMEnv@ extends a match environment, checking for overlaps.
-
-\begin{code}
-insertMEnv :: (key {- template -} -> -- Matching function
- key {- instance -} ->
- Maybe match_info)
- -> MatchEnv key value -- Envt
- -> key -> value -- New item
- -> MaybeErr (MatchEnv key value) -- Success...
- (key, value) -- Failure: Offending overlap
-
-insertMEnv match_fn alist key value
- = insert alist
- where
- -- insert has to put the new item in BEFORE any keys which are
- -- LESS SPECIFIC than the new key, and AFTER any keys which are
- -- MORE SPECIFIC The list is maintained in specific-ness order, so
- -- we just stick it in either last, or just before the first key
- -- of which the new key is an instance. We check for overlap at
- -- that point.
-
- insert [] = returnMaB [(key, value)]
- insert ((t,v) : rest)
- = case (match_fn t key) of
- Nothing ->
- -- New key is not an instance of this existing one, so
- -- continue down the list.
- insert rest `thenMaB` (\ rest' ->
- returnMaB ((t,v):rest') )
-
- Just match_info ->
- -- New key *is* an instance of the old one, so check the
- -- other way round in case of identity.
-
- case (match_fn key t) of
- Just _ -> failMaB (t,v)
- -- Oops; overlap
-
- Nothing -> returnMaB ((key,value):(t,v):rest)
- -- All ok; insert here
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface LIE where
-import Inst(Inst)
-data Inst
-data LIE
-mkLIE :: [Inst] -> LIE
-nullLIE :: LIE
-plusLIE :: LIE -> LIE -> LIE
-unMkLIE :: LIE -> [Inst]
-unitLIE :: Inst -> LIE
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[LIE]{Id instance environment}
-
-This is not really an ``environment.''
-
-\begin{code}
-#include "HsVersions.h"
-
-module LIE (
- LIE, -- abstract type
- mkLIE, nullLIE, unitLIE, unMkLIE, plusLIE,
-
- -- imported things so this module's interface is self-contained
- Inst
- ) where
-
-import Inst ( Inst )
-import Outputable
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[LIE-building]{Building LIEs}
-%* *
-%************************************************************************
-
-\begin{code}
-data LIE = MkLIE [Inst]
-
-mkLIE = MkLIE
-
-nullLIE = MkLIE []
-unitLIE x = MkLIE [x]
-
-unMkLIE :: LIE -> [Inst]
-unMkLIE (MkLIE insts) = insts
-
-plusLIE :: LIE -> LIE -> LIE
-plusLIE (MkLIE lie1) (MkLIE lie2)
- = MkLIE (lie1 ++ lie2)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TCE where
-import CharSeq(CSeq)
-import ErrUtils(Error(..))
-import Id(Id)
-import Maybes(MaybeErr)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import UniqFM(UniqFM)
-import Unique(Unique)
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data MaybeErr a b
-data Name
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data SrcLoc
-type TCE = UniqFM TyCon
-data TyCon
-data UniqFM a
-checkTypeCycles :: UniqFM TyCon -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep)
-lookupTCE :: UniqFM TyCon -> Name -> TyCon
-nullTCE :: UniqFM TyCon
-plusTCE :: UniqFM TyCon -> UniqFM TyCon -> UniqFM TyCon
-rngTCE :: UniqFM TyCon -> [TyCon]
-unitTCE :: Unique -> TyCon -> UniqFM TyCon
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TCE]{Type constructor environment}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TCE (
- TCE(..), UniqFM,
- nullTCE, unitTCE,
- rngTCE,
- lookupTCE,
- plusTCE, checkTypeCycles,
--- NOT REALLY USED: printTypeInfoForPop,
-
- -- and to make the interface self-sufficient...
- MaybeErr, Name, TyCon,
- Error(..), SrcLoc, Pretty(..), PrettyRep
-
- IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
- IF_ATTACK_PRAGMAS(COMMA eltsUFM COMMA singletonDirectlyUFM)
- IF_ATTACK_PRAGMAS(COMMA u2i)
- ) where
-
-import AbsUniType ( getMentionedTyCons, isDataTyCon, getTyConDataCons,
- TyCon, Arity(..), Class, UniType
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Digraph ( topologicalSort )
-import Errors -- notably typeCycleErr
-import Id ( getDataConArity, Id, DataCon(..) )
-import Maybes ( Maybe(..), MaybeErr(..) )
-import Name
-import Outputable
-import Pretty
-import UniqFM -- basic environment handling
-import Unique ( Unique )
-import Util
-\end{code}
-
-\begin{code}
---data TCE = MkTCE (UniqFM TyCon)
-type TCE = UniqFM TyCon
-#define MkTCE {--}
--- also killed instance TCE, exported non-abstractly
-
-nullTCE :: TCE
-nullTCE = MkTCE emptyUFM
-
-unitTCE :: Unique -> TyCon -> TCE
-unitTCE uniq tycon = MkTCE (singletonDirectlyUFM uniq tycon)
-
-rngTCE :: TCE -> [TyCon]
-rngTCE (MkTCE tce) = eltsUFM tce
-
-lookupTCE :: TCE -> Name -> TyCon
-lookupTCE (MkTCE tce) name
- = case name of
- WiredInTyCon tycon -> tycon
- PreludeTyCon key _ _ _ -> case (lookupDirectlyUFM tce key) of
- Just tycon -> tycon
- Nothing -> err_msg
- OtherTyCon uniq _ _ _ _ -> case (lookupDirectlyUFM tce uniq) of
- Just tycon -> tycon
- Nothing -> err_msg
- where
- err_msg = error ("ERROR: in looking up a type constructor! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide or change the system's Prelude.hi in some way.\nA -fhaskell-1.3 flag, or lack thereof, can trigger this error.)\n")
-
-plusTCE :: TCE -> TCE -> TCE
-plusTCE (MkTCE tce1) (MkTCE tce2) = MkTCE (plusUFM tce1 tce2)
-\end{code}
-
-\begin{code}
-checkTypeCycles :: TCE -> MaybeErr () Error
-checkTypeCycles tce
- = case (topologicalSort (==) edges vertices) of
- Succeeded ordering -> Succeeded ()
- Failed cycles
- -> Failed (typeCycleErr (map (\ c -> map fmt_tycon c) cycles))
- where
- fmt_tycon c = (ppr PprForUser c, getSrcLoc c)
- where
- vertices = [ vertex1 | (vertex1, vertex2) <- edges]
- edges = concat (map get_edges (rngTCE tce))
- where
- get_edges tycon = [(tycon, dep) | dep <- getMentionedTyCons tycon]
- -- Make an arc for every dependency
-\end{code}
-
-\begin{code}
-{- NOT REALLY USED:
-printTypeInfoForPop :: TCE -> Pretty
-
-printTypeInfoForPop (MkTCE tce)
- = ppAboves [ pp_type tc | tc <- eltsUFM tce, isDataTyCon tc ]
- where
- pp_type tycon
- = ppBesides [
- ppStr "data ",
- ppr PprForUser tycon, ppSP,
- ppInterleave ppSP (map pp_data_con (getTyConDataCons tycon)),
- ppSemi
- ]
- where
- pp_data_con data_con
- = ppCat [ppr PprForUser data_con, ppInt (getDataConArity data_con)]
--}
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TVE where
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Labda a
-data Name
-type TVE = UniqFM UniType
-data TyVarTemplate
-data UniType
-data UniqFM a
-lookupTVE :: UniqFM UniType -> Name -> UniType
-lookupTVE_NoFail :: UniqFM a -> Name -> Labda a
-mkTVE :: [Name] -> (UniqFM UniType, [TyVarTemplate], [UniType])
-nullTVE :: UniqFM UniType
-plusTVE :: UniqFM UniType -> UniqFM UniType -> UniqFM UniType
-unitTVE :: Unique -> a -> UniqFM a
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[TVE]{Type variable environment}
-
-This environment is not part of the big one that is carried around
-monadically.
-
-\begin{code}
-#include "HsVersions.h"
-
-module TVE (
- TVE(..), UniqFM,
-
- mkTVE, nullTVE, unitTVE,
- lookupTVE, lookupTVE_NoFail, plusTVE,
-
- -- and to make the interface self-sufficient...
- Maybe, Name, TyVarTemplate, UniType
-
- IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
- IF_ATTACK_PRAGMAS(COMMA eltsUFM COMMA singletonDirectlyUFM)
- IF_ATTACK_PRAGMAS(COMMA u2i)
- ) where
-
-import AbsUniType ( mkUserTyVarTemplate, mkTyVarTemplateTy,
- getTyVar, TyVarTemplate, TyVar, Class,
- ClassOp, Arity(..), TyCon,
- TauType(..), UniType
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Maybes ( Maybe(..), MaybeErr(..) )
-import Name
-import Outputable -- def of ppr
-import Pretty -- to pretty-print error messages
-import UniqFM -- basic environment handling
-import Unique ( Unique )
-import Util
-\end{code}
-
-\begin{code}
-type TVE = UniqFM UniType
-#define MkTVE {--}
--- also: export non-abstractly
-
-mkTVE :: [Name] -> (TVE, [TyVarTemplate], [TauType])
-mkTVE names
- = case (unzip3 (map mk_tve_one names)) of { (env, tyvars, tys) ->
- (MkTVE (listToUFM_Directly env), tyvars, tys) }
- where
- mk_tve_one (Short uniq short_name)
- = case (mkUserTyVarTemplate uniq short_name) of { tyvar ->
- case (mkTyVarTemplateTy tyvar) of { ty ->
- ((uniq, ty), tyvar, ty) }}
-
-nullTVE :: TVE
-nullTVE = MkTVE emptyUFM
-
-unitTVE u ty = MkTVE (singletonDirectlyUFM u ty)
-
-lookupTVE :: TVE -> Name -> UniType
-lookupTVE (MkTVE tve) (Short uniq short_name)
- = case (lookupDirectlyUFM tve uniq) of
- Just ty -> ty
- Nothing -> panic "lookupTVE!"
-
-lookupTVE_NoFail (MkTVE tve) (Short uniq short_name)
- = lookupDirectlyUFM tve uniq
-
-plusTVE :: TVE -> TVE -> TVE
-plusTVE (MkTVE tve1) (MkTVE tve2) = MkTVE (plusUFM tve1 tve2)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TyVarEnv where
-import Maybes(Labda(..))
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Labda a = Hamna | Ni a
-data TyVar
-type TyVarEnv a = UniqFM a
-type TypeEnv = UniqFM UniType
-data UniqFM a
-data Unique
-addOneToTyVarEnv :: UniqFM a -> TyVar -> a -> UniqFM a
-growTyVarEnvList :: UniqFM a -> [(TyVar, a)] -> UniqFM a
-isNullTyVarEnv :: UniqFM a -> Bool
-lookupTyVarEnv :: UniqFM a -> TyVar -> Labda a
-mkTyVarEnv :: [(TyVar, a)] -> UniqFM a
-nullTyVarEnv :: UniqFM a
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994
-%
-\section[TyVarEnv]{Lookup tables that have @TyVar@ keys}
-
-An interface to the @FiniteMap@ machinery, which exports
-a ``personality'' the same as that of the old @TyVarEnv@ module.
-
-\begin{code}
-#include "HsVersions.h"
-
-module TyVarEnv (
- TyVarEnv(..), -- abstract: NOT
-
- TypeEnv(..), -- most common/important kind of TyVarEnv
-
- mkTyVarEnv,
- lookupTyVarEnv,
- nullTyVarEnv, growTyVarEnvList,
- isNullTyVarEnv,
- addOneToTyVarEnv,
-
- -- and to make the interface self-sufficient...
- UniqFM,
- TyVar, Unique, Maybe(..)
-
-#ifdef USE_ATTACK_PRAGMAS
- , addToUFM, plusUFM_C, delListFromUFM, delFromUFM, plusUFM,
- lookupUFM, mapUFM, minusUFM, listToUFM, emptyUFM, eltsUFM,
- singletonUFM,
- u2i
-#endif
- ) where
-
-import AbsUniType
-import UniqFM
-import Maybes ( Maybe(..) )
-import Outputable
-import Unique ( Unique, u2i )
-import Util
-\end{code}
-
-\begin{code}
-type TyVarEnv elt = UniqFM elt
-
-type TypeEnv = TyVarEnv UniType -- most common flavo(u)r
-\end{code}
-
-Signatures:
-\begin{code}
-mkTyVarEnv :: [(TyVar, a)] -> TyVarEnv a
-addOneToTyVarEnv :: TyVarEnv a -> TyVar -> a -> TyVarEnv a
-growTyVarEnvList :: TyVarEnv a -> [(TyVar, a)] -> TyVarEnv a
-isNullTyVarEnv :: TyVarEnv a -> Bool
-lookupTyVarEnv :: TyVarEnv a -> TyVar -> Maybe a
-nullTyVarEnv :: TyVarEnv a
-\end{code}
-
-\begin{code}
-mkTyVarEnv stuff = listToUFM stuff
-
-addOneToTyVarEnv env id elt = addToUFM env id elt
-
-growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
-
-isNullTyVarEnv env = sizeUFM env == 0
-
-lookupTyVarEnv env id = lookupUFM env id
-
-nullTyVarEnv = emptyUFM
-\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsBinds]{Abstract syntax: top-level bindings and signatures}
+
+Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsBinds where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsLoop
+
+import HsMatches ( pprMatches, pprGRHSsAndBinds,
+ Match, GRHSsAndBinds
+ )
+import HsPat ( collectPatBinders, InPat )
+import HsPragmas ( GenPragmas, ClassOpPragmas )
+import HsTypes ( PolyType )
+
+--others:
+import Id ( DictVar(..), Id(..), GenId )
+import Outputable
+import PprType ( pprType )
+import Pretty
+import SrcLoc ( SrcLoc{-instances-} )
+import TyVar ( GenTyVar{-instances-} )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Bindings: @HsBinds@}
+%* *
+%************************************************************************
+
+The following syntax may produce new syntax which is not part of the input,
+and which is instead a translation of the input to the typechecker.
+Syntax translations are marked TRANSLATION in comments. New empty
+productions are useful in development but may not appear in the final
+grammar.
+
+Collections of bindings, created by dependency analysis and translation:
+
+\begin{code}
+data HsBinds tyvar uvar id pat -- binders and bindees
+ = EmptyBinds
+
+ | ThenBinds (HsBinds tyvar uvar id pat)
+ (HsBinds tyvar uvar id pat)
+
+ | SingleBind (Bind tyvar uvar id pat)
+
+ | BindWith -- Bind with a type signature.
+ -- These appear only on typechecker input
+ -- (PolyType [in Sigs] can't appear on output)
+ (Bind tyvar uvar id pat)
+ [Sig id]
+
+ | AbsBinds -- Binds abstraction; TRANSLATION
+ [tyvar]
+ [id] -- Dicts
+ [(id, id)] -- (old, new) pairs
+ [(id, HsExpr tyvar uvar id pat)] -- local dictionaries
+ (Bind tyvar uvar id pat) -- "the business end"
+
+ -- Creates bindings for *new* (polymorphic, overloaded) locals
+ -- in terms of *old* (monomorphic, non-overloaded) ones.
+ --
+ -- See section 9 of static semantics paper for more details.
+ -- (You can get a PhD for explaining the True Meaning
+ -- of this last construct.)
+\end{code}
+
+\begin{code}
+nullBinds :: HsBinds tyvar uvar id pat -> Bool
+
+nullBinds EmptyBinds = True
+nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
+nullBinds (SingleBind b) = nullBind b
+nullBinds (BindWith b _) = nullBind b
+nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b
+\end{code}
+
+\begin{code}
+instance (Outputable pat, NamedThing id, Outputable id,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (HsBinds tyvar uvar id pat) where
+
+ ppr sty EmptyBinds = ppNil
+ ppr sty (ThenBinds binds1 binds2)
+ = ppAbove (ppr sty binds1) (ppr sty binds2)
+ ppr sty (SingleBind bind) = ppr sty bind
+ ppr sty (BindWith bind sigs)
+ = ppAbove (if null sigs
+ then ppNil
+ else ppAboves (map (ppr sty) sigs))
+ (ppr sty bind)
+ ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
+ = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
+ ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
+ ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
+ ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
+ (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@Sig@: type signatures and value-modifying user pragmas}
+%* *
+%************************************************************************
+
+It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
+``specialise this function to these four types...'') in with type
+signatures. Then all the machinery to move them into place, etc.,
+serves for both.
+
+\begin{code}
+data Sig name
+ = Sig name -- a bog-std type signature
+ (PolyType name)
+ (GenPragmas name) -- only interface ones have pragmas
+ SrcLoc
+
+ | ClassOpSig name -- class-op sigs have different pragmas
+ (PolyType name)
+ (ClassOpPragmas name) -- only interface ones have pragmas
+ SrcLoc
+
+ | SpecSig name -- specialise a function or datatype ...
+ (PolyType name) -- ... to these types
+ (Maybe name) -- ... maybe using this as the code for it
+ SrcLoc
+
+ | InlineSig name -- INLINE f
+ SrcLoc
+
+ -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
+ | DeforestSig name -- Deforest using this function definition
+ SrcLoc
+
+ | MagicUnfoldingSig
+ name -- Associate the "name"d function with
+ FAST_STRING -- the compiler-builtin unfolding (known
+ SrcLoc -- by the String name)
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name) => Outputable (Sig name) where
+ ppr sty (Sig var ty pragmas _)
+ = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
+ 4 (ppHang (ppr sty ty)
+ 4 (ifnotPprForUser sty (ppr sty pragmas)))
+
+ ppr sty (ClassOpSig var ty pragmas _)
+ = ppHang (ppCat [pprNonOp sty var, ppPStr SLIT("::")])
+ 4 (ppHang (ppr sty ty)
+ 4 (ifnotPprForUser sty (ppr sty pragmas)))
+
+ ppr sty (DeforestSig var _)
+ = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonOp sty var])
+ 4 (ppStr "#-}")
+
+ ppr sty (SpecSig var ty using _)
+ = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonOp sty var, ppPStr SLIT("::")])
+ 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
+ where
+ pp_using Nothing = ppNil
+ pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
+
+ ppr sty (InlineSig var _)
+ = ppCat [ppPStr SLIT("{-# INLINE"), pprNonOp sty var, ppPStr SLIT("#-}")]
+
+ ppr sty (MagicUnfoldingSig var str _)
+ = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonOp sty var, ppPStr str, ppPStr SLIT("#-}")]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Binding: @Bind@}
+%* *
+%************************************************************************
+
+\begin{code}
+data Bind tyvar uvar id pat -- binders and bindees
+ = EmptyBind -- because it's convenient when parsing signatures
+ | NonRecBind (MonoBinds tyvar uvar id pat)
+ | RecBind (MonoBinds tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+nullBind :: Bind tyvar uvar id pat -> Bool
+
+nullBind EmptyBind = True
+nullBind (NonRecBind bs) = nullMonoBinds bs
+nullBind (RecBind bs) = nullMonoBinds bs
+\end{code}
+
+\begin{code}
+bindIsRecursive :: Bind tyvar uvar id pat -> Bool
+
+bindIsRecursive EmptyBind = False
+bindIsRecursive (NonRecBind _) = False
+bindIsRecursive (RecBind _) = True
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (Bind tyvar uvar id pat) where
+ ppr sty EmptyBind = ppNil
+ ppr sty (NonRecBind binds)
+ = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
+ (ppr sty binds)
+ ppr sty (RecBind binds)
+ = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
+ (ppr sty binds)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Bindings: @MonoBinds@}
+%* *
+%************************************************************************
+
+Global bindings (where clauses)
+
+\begin{code}
+data MonoBinds tyvar uvar id pat
+ = EmptyMonoBinds
+ | AndMonoBinds (MonoBinds tyvar uvar id pat)
+ (MonoBinds tyvar uvar id pat)
+ | PatMonoBind pat
+ (GRHSsAndBinds tyvar uvar id pat)
+ SrcLoc
+ | FunMonoBind id
+ [Match tyvar uvar id pat] -- must have at least one Match
+ SrcLoc
+ | VarMonoBind id -- TRANSLATION
+ (HsExpr tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
+
+nullMonoBinds EmptyMonoBinds = True
+nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
+nullMonoBinds other_monobind = False
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (MonoBinds tyvar uvar id pat) where
+ ppr sty EmptyMonoBinds = ppNil
+ ppr sty (AndMonoBinds binds1 binds2)
+ = ppAbove (ppr sty binds1) (ppr sty binds2)
+
+ ppr sty (PatMonoBind pat grhss_n_binds locn)
+ = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
+
+ ppr sty (FunMonoBind fun matches locn)
+ = pprMatches sty (False, pprNonOp sty fun) matches
+
+ ppr sty (VarMonoBind name expr)
+ = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Collecting binders from @HsBinds@}
+%* *
+%************************************************************************
+
+Get all the binders in some @MonoBinds@, IN THE ORDER OF
+APPEARANCE; e.g., in:
+\begin{verbatim}
+...
+where
+ (x, y) = ...
+ f i j = ...
+ [a, b] = ...
+\end{verbatim}
+it should return @[x, y, f, a, b]@ (remember, order important).
+
+\begin{code}
+collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name]
+collectTopLevelBinders EmptyBinds = []
+collectTopLevelBinders (SingleBind b) = collectBinders b
+collectTopLevelBinders (BindWith b _) = collectBinders b
+collectTopLevelBinders (ThenBinds b1 b2)
+ = collectTopLevelBinders b1 ++ collectTopLevelBinders b2
+
+collectBinders :: Bind tyvar uvar name (InPat name) -> [name]
+collectBinders EmptyBind = []
+collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
+collectBinders (RecBind monobinds) = collectMonoBinders monobinds
+
+collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
+collectMonoBinders EmptyMonoBinds = []
+collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
+collectMonoBinders (FunMonoBind f matches _) = [f]
+collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
+collectMonoBinders (AndMonoBinds bs1 bs2)
+ = collectMonoBinders bs1 ++ collectMonoBinders bs2
+
+-- We'd like the binders -- and where they came from --
+-- so we can make new ones with equally-useful origin info.
+
+collectMonoBindersAndLocs
+ :: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)]
+
+collectMonoBindersAndLocs EmptyMonoBinds = []
+
+collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
+ = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
+
+collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
+ = collectPatBinders pat `zip` repeat locn
+
+collectMonoBindersAndLocs (FunMonoBind f matches locn) = [(f, locn)]
+
+#ifdef DEBUG
+collectMonoBindersAndLocs (VarMonoBind v expr)
+ = trace "collectMonoBindersAndLocs:VarMonoBind" []
+ -- ToDo: this is dubious, i.e., wrong, but harmless?
+#endif
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+%
+%************************************************************************
+%* *
+\section[HsCore]{Core-syntax unfoldings in Haskell interface files}
+%* *
+%************************************************************************
+
+We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
+@TyVars@ as well. Currently trying the former.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsCore (
+ -- types:
+ UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
+ UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
+ UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
+ UnfoldingPrimOp(..), UfCostCentre(..),
+
+ -- function:
+ eqUfExpr
+ ) where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsTypes ( cmpPolyType, MonoType(..), PolyType(..) )
+import PrimOp ( PrimOp, tagOf_PrimOp )
+
+-- others:
+import Literal ( Literal )
+import Outputable ( Outputable(..) {-instances-} )
+import Pretty
+import ProtoName ( cmpProtoName, eqProtoName, ProtoName )
+import Util ( panic )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[HsCore-types]{Types for read/written Core unfoldings}
+%* *
+%************************************************************************
+
+\begin{code}
+data UnfoldingCoreExpr name
+ = UfVar (UfId name)
+ | UfLit Literal
+ | UfCon name -- must be a "BoringUfId"...
+ [UnfoldingType name]
+ [UnfoldingCoreAtom name]
+ | UfPrim (UnfoldingPrimOp name)
+ [UnfoldingType name]
+ [UnfoldingCoreAtom name]
+ | UfLam (UfBinder name)
+ (UnfoldingCoreExpr name)
+ | UfApp (UnfoldingCoreExpr name)
+ (UnfoldingCoreAtom name)
+ | UfCase (UnfoldingCoreExpr name)
+ (UnfoldingCoreAlts name)
+ | UfLet (UnfoldingCoreBinding name)
+ (UnfoldingCoreExpr name)
+ | UfSCC (UfCostCentre name)
+ (UnfoldingCoreExpr name)
+
+data UnfoldingPrimOp name
+ = UfCCallOp FAST_STRING -- callee
+ Bool -- True <=> casm, rather than ccall
+ Bool -- True <=> might cause GC
+ [UnfoldingType name] -- arg types, incl state token
+ -- (which will be first)
+ (UnfoldingType name) -- return type
+ | UfOtherOp PrimOp
+
+data UnfoldingCoreAlts name
+ = UfCoAlgAlts [(name, [UfBinder name], UnfoldingCoreExpr name)]
+ (UnfoldingCoreDefault name)
+ | UfCoPrimAlts [(Literal, UnfoldingCoreExpr name)]
+ (UnfoldingCoreDefault name)
+
+data UnfoldingCoreDefault name
+ = UfCoNoDefault
+ | UfCoBindDefault (UfBinder name)
+ (UnfoldingCoreExpr name)
+
+data UnfoldingCoreBinding name
+ = UfCoNonRec (UfBinder name)
+ (UnfoldingCoreExpr name)
+ | UfCoRec [(UfBinder name, UnfoldingCoreExpr name)]
+
+data UnfoldingCoreAtom name
+ = UfCoVarAtom (UfId name)
+ | UfCoLitAtom Literal
+
+data UfCostCentre name
+ = UfPreludeDictsCC
+ Bool -- True <=> is dupd
+ | UfAllDictsCC FAST_STRING -- module and group
+ FAST_STRING
+ Bool -- True <=> is dupd
+ | UfUserCC FAST_STRING
+ FAST_STRING FAST_STRING -- module and group
+ Bool -- True <=> is dupd
+ Bool -- True <=> is CAF
+ | UfAutoCC (UfId name)
+ FAST_STRING FAST_STRING -- module and group
+ Bool Bool -- as above
+ | UfDictCC (UfId name)
+ FAST_STRING FAST_STRING -- module and group
+ Bool Bool -- as above
+
+type UfBinder name = (name, UnfoldingType name)
+
+data UfId name
+ = BoringUfId name
+ | SuperDictSelUfId name name -- class and superclass
+ | ClassOpUfId name name -- class and class op
+ | DictFunUfId name -- class and type
+ (UnfoldingType name)
+ | ConstMethodUfId name name -- class, class op, and type
+ (UnfoldingType name)
+ | DefaultMethodUfId name name -- class and class op
+ | SpecUfId (UfId name) -- its unspecialised "parent"
+ [Maybe (MonoType name)]
+ | WorkerUfId (UfId name) -- its non-working "parent"
+ -- more to come?
+
+type UnfoldingType name = PolyType name
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[HsCore-print]{Printing Core unfoldings}
+%* *
+%************************************************************************
+
+\begin{code}
+instance Outputable name => Outputable (UnfoldingCoreExpr name) where
+ ppr sty (UfVar v) = pprUfId sty v
+ ppr sty (UfLit l) = ppr sty l
+
+ ppr sty (UfCon c tys as)
+ = ppCat [ppStr "(UfCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"]
+ ppr sty (UfPrim o tys as)
+ = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"]
+
+ ppr sty (UfLam bs body)
+ = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
+
+ ppr sty (UfApp fun arg)
+ = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"]
+
+ ppr sty (UfCase scrut alts)
+ = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
+ where
+ pp_alts (UfCoAlgAlts alts deflt)
+ = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
+ where
+ pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
+ pp_alts (UfCoPrimAlts alts deflt)
+ = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
+ where
+ pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
+
+ pp_deflt UfCoNoDefault = ppNil
+ pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
+
+ ppr sty (UfLet (UfCoNonRec b rhs) body)
+ = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
+ ppr sty (UfLet (UfCoRec pairs) body)
+ = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
+ where
+ pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
+
+ ppr sty (UfSCC uf_cc body)
+ = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
+
+instance Outputable name => Outputable (UnfoldingPrimOp name) where
+ ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
+ = let
+ before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
+ after = if is_casm then ppStr "'' " else ppSP
+ in
+ ppBesides [before, ppPStr str, after,
+ ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+ ppr sty (UfOtherOp op)
+ = ppr sty op
+
+instance Outputable name => Outputable (UnfoldingCoreAtom name) where
+ ppr sty (UfCoVarAtom v) = pprUfId sty v
+ ppr sty (UfCoLitAtom l) = ppr sty l
+
+pprUfId sty (BoringUfId v) = ppr sty v
+pprUfId sty (SuperDictSelUfId c sc)
+ = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"]
+pprUfId sty (ClassOpUfId c op)
+ = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"]
+pprUfId sty (DictFunUfId c ty)
+ = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
+pprUfId sty (ConstMethodUfId c op ty)
+ = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"]
+pprUfId sty (DefaultMethodUfId c ty)
+ = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
+
+pprUfId sty (SpecUfId unspec ty_maybes)
+ = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec,
+ ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"]
+ where
+ pp_ty_maybe Nothing = ppStr "_N_"
+ pp_ty_maybe (Just t) = ppr sty t
+
+pprUfId sty (WorkerUfId unwrkr)
+ = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[HsCore-equality]{Comparing Core unfoldings}
+%* *
+%************************************************************************
+
+We want to check that they are {\em exactly} the same.
+
+\begin{code}
+--eqUfExpr :: ProtoNameCoreExpr -> ProtoNameCoreExpr -> Bool
+
+eqUfExpr (UfVar v1) (UfVar v2) = eqUfId v1 v2
+eqUfExpr (UfLit l1) (UfLit l2) = l1 == l2
+
+eqUfExpr (UfCon c1 tys1 as1) (UfCon c2 tys2 as2)
+ = eq_name c1 c2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
+eqUfExpr (UfPrim o1 tys1 as1) (UfPrim o2 tys2 as2)
+ = eq_op o1 o2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
+ where
+ eq_op (UfCCallOp _ _ _ _ _) (UfCCallOp _ _ _ _ _) = True
+ eq_op (UfOtherOp o1) (UfOtherOp o2)
+ = tagOf_PrimOp o1 _EQ_ tagOf_PrimOp o2
+
+eqUfExpr (UfLam bs1 body1) (UfLam bs2 body2)
+ = eq_binder bs1 bs2 && eqUfExpr body1 body2
+
+eqUfExpr (UfApp fun1 arg1) (UfApp fun2 arg2)
+ = eqUfExpr fun1 fun2 && eq_atom arg1 arg2
+
+eqUfExpr (UfCase scrut1 alts1) (UfCase scrut2 alts2)
+ = eqUfExpr scrut1 scrut2 && eq_alts alts1 alts2
+ where
+ eq_alts (UfCoAlgAlts alts1 deflt1) (UfCoAlgAlts alts2 deflt2)
+ = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
+ where
+ eq_alt (c1,bs1,rhs1) (c2,bs2,rhs2)
+ = eq_name c1 c2 && eq_lists eq_binder bs1 bs2 && eqUfExpr rhs1 rhs2
+
+ eq_alts (UfCoPrimAlts alts1 deflt1) (UfCoPrimAlts alts2 deflt2)
+ = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
+ where
+ eq_alt (l1,rhs1) (l2,rhs2)
+ = l1 == l2 && eqUfExpr rhs1 rhs2
+
+ eq_alts _ _ = False -- catch-all
+
+ eq_deflt UfCoNoDefault UfCoNoDefault = True
+ eq_deflt (UfCoBindDefault b1 rhs1) (UfCoBindDefault b2 rhs2)
+ = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
+ eq_deflt _ _ = False
+
+eqUfExpr (UfLet (UfCoNonRec b1 rhs1) body1) (UfLet (UfCoNonRec b2 rhs2) body2)
+ = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 && eqUfExpr body1 body2
+
+eqUfExpr (UfLet (UfCoRec pairs1) body1) (UfLet (UfCoRec pairs2) body2)
+ = eq_lists eq_pair pairs1 pairs2 && eqUfExpr body1 body2
+ where
+ eq_pair (b1,rhs1) (b2,rhs2) = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
+
+eqUfExpr (UfSCC cc1 body1) (UfSCC cc2 body2)
+ = {-trace "eqUfExpr: not comparing cost-centres!"-} (eqUfExpr body1 body2)
+
+eqUfExpr _ _ = False -- Catch-all
+\end{code}
+
+\begin{code}
+eqUfId (BoringUfId n1) (BoringUfId n2)
+ = eq_name n1 n2
+eqUfId (SuperDictSelUfId a1 b1) (SuperDictSelUfId a2 b2)
+ = eq_name a1 a2 && eq_name b1 b2
+eqUfId (ClassOpUfId a1 b1) (ClassOpUfId a2 b2)
+ = eq_name a1 a2 && eq_name b1 b2
+eqUfId (DictFunUfId c1 t1) (DictFunUfId c2 t2)
+ = eq_name c1 c2 && eq_tycon t1 t2 -- NB: **** only compare TyCons ******
+ where
+ eq_tycon = panic "HsCore:eqUfId:eq_tycon:ToDo"
+{- LATER:
+ eq_tycon (UnoverloadedTy ty1) (UnoverloadedTy ty2)
+ = case (cmpInstanceTypes ty1 ty2) of { EQ_ -> True; _ -> False }
+ eq_tycon ty1 ty2
+ = trace "eq_tycon" (eq_type ty1 ty2) -- desperately try something else
+-}
+
+eqUfId (ConstMethodUfId a1 b1 t1) (ConstMethodUfId a2 b2 t2)
+ = eq_name a1 a2 && eq_name b1 b2 && eq_type t1 t2
+eqUfId (DefaultMethodUfId a1 b1) (DefaultMethodUfId a2 b2)
+ = eq_name a1 a2 && eq_name b1 b2
+eqUfId (SpecUfId id1 tms1) (SpecUfId id2 tms2)
+ = eqUfId id1 id2 && eq_lists eq_ty_maybe tms1 tms2
+ where
+ eq_ty_maybe = panic "HsCore:eqUfId:eq_ty_maybe:ToDo"
+{-
+ eq_ty_maybe Nothing Nothing = True
+ eq_ty_maybe (Just ty1) (Just ty2)
+ = eq_type (UnoverloadedTy ty1) (UnoverloadedTy ty2)
+ -- a HACKy way to compare MonoTypes (ToDo) [WDP 94/05/02]
+ eq_ty_maybe _ _ = False
+-}
+eqUfId (WorkerUfId id1) (WorkerUfId id2)
+ = eqUfId id1 id2
+eqUfId _ _ = False -- catch-all
+\end{code}
+
+\begin{code}
+eq_atom (UfCoVarAtom id1) (UfCoVarAtom id2) = eqUfId id1 id2
+eq_atom (UfCoLitAtom l1) (UfCoLitAtom l2) = l1 == l2
+eq_atom _ _ = False
+
+eq_binder (n1, ty1) (n2, ty2) = eq_name n1 n2 && eq_type ty1 ty2
+
+eq_name :: ProtoName -> ProtoName -> Bool
+eq_name pn1 pn2 = eqProtoName pn1 pn2 -- uses original names
+
+eq_type ty1 ty2
+ = case (cmpPolyType cmpProtoName ty1 ty2) of { EQ_ -> True; _ -> False }
+\end{code}
+
+\begin{code}
+eq_lists :: (a -> a -> Bool) -> [a] -> [a] -> Bool
+
+eq_lists eq [] [] = True
+eq_lists eq [] _ = False
+eq_lists eq _ [] = False
+eq_lists eq (x:xs) (y:ys) = eq x y && eq_lists eq xs ys
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsDecls]{Abstract syntax: global declarations}
+
+Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
+@InstDecl@, @DefaultDecl@.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsDecls where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsLoop ( nullMonoBinds, MonoBinds, Sig )
+import HsPragmas ( DataPragmas, ClassPragmas,
+ InstancePragmas, ClassOpPragmas
+ )
+import HsTypes
+
+-- others:
+import Outputable
+import Pretty
+import ProtoName ( cmpProtoName, ProtoName )
+import SrcLoc ( SrcLoc )
+import Util ( cmpList, panic#{-ToDo:rm eventually-} )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[FixityDecl]{A fixity declaration}
+%* *
+%************************************************************************
+
+These are only used in generating interfaces at the moment. They are
+not used in pretty-printing.
+
+\begin{code}
+data FixityDecl name
+ = InfixL name Int
+ | InfixR name Int
+ | InfixN name Int
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name)
+ => Outputable (FixityDecl name) where
+ ppr sty (InfixL var prec) = print_it sty "l" prec var
+ ppr sty (InfixR var prec) = print_it sty "r" prec var
+ ppr sty (InfixN var prec) = print_it sty "" prec var
+
+print_it sty suff prec var
+ = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprOp sty var]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
+%* *
+%************************************************************************
+
+\begin{code}
+data TyDecl name
+ = TyData (Context name) -- context
+ name -- type constructor
+ [name] -- type variables
+ [ConDecl name] -- data constructors (empty if abstract)
+ (Maybe [name]) -- derivings; Nothing => not specified
+ -- (i.e., derive default); Just [] => derive
+ -- *nothing*; Just <list> => as you would
+ -- expect...
+ (DataPragmas name)
+ SrcLoc
+
+ | TyNew (Context name) -- context
+ name -- type constructor
+ [name] -- type variables
+ [ConDecl name] -- data constructor (empty if abstract)
+ (Maybe [name]) -- derivings; as above
+ (DataPragmas name)
+ SrcLoc
+
+ | TySynonym name -- type constructor
+ [name] -- type variables
+ (MonoType name) -- synonym expansion
+ SrcLoc
+
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name)
+ => Outputable (TyDecl name) where
+
+ ppr sty (TySynonym tycon tyvars mono_ty src_loc)
+ = ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars)
+ 4 (ppCat [ppEquals, ppr sty mono_ty])
+
+ ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
+ = pp_tydecl sty
+ (pp_decl_head sty SLIT("data") (pprContext sty context) tycon tyvars)
+ (pp_condecls sty condecls)
+ derivings
+
+ ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc)
+ = pp_tydecl sty
+ (pp_decl_head sty SLIT("newtype") (pprContext sty context) tycon tyvars)
+ (pp_condecls sty condecl)
+ derivings
+
+pp_decl_head sty str pp_context tycon tyvars
+ = ppCat [ppPStr str, pp_context, ppr sty tycon, interppSP sty tyvars]
+
+pp_condecls sty [] = ppNil -- abstract datatype
+pp_condecls sty (c:cs)
+ = ppSep (ppBeside (ppStr "= ") (ppr sty c)
+ : map (\ x -> ppBeside (ppStr "| ") (ppr sty x)) cs)
+
+pp_tydecl sty pp_head pp_decl_rhs derivings
+ = ppHang pp_head 4 (ppSep [
+ pp_decl_rhs,
+ case derivings of
+ Nothing -> ppNil
+ Just ds -> ppBeside (ppPStr SLIT("deriving "))
+ (ppParens (ppInterleave ppComma (map (ppr sty) ds)))])
+\end{code}
+
+A type for recording what types a datatype should be specialised to.
+It's called a ``Sig'' because it's sort of like a ``type signature''
+for an datatype declaration.
+
+\begin{code}
+data SpecDataSig name
+ = SpecDataSig name -- tycon to specialise
+ (MonoType name)
+ SrcLoc
+
+instance (NamedThing name, Outputable name)
+ => Outputable (SpecDataSig name) where
+
+ ppr sty (SpecDataSig tycon ty _)
+ = ppCat [ppStr "{-# SPECIALIZE data", ppr sty ty, ppStr "#-}"]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[ConDecl]{A data-constructor declaration}
+%* *
+%************************************************************************
+
+\begin{code}
+data ConDecl name
+ = ConDecl name -- prefix-style con decl
+ [BangType name]
+ SrcLoc
+
+ | ConOpDecl (BangType name) -- infix-style con decl
+ name
+ (BangType name)
+ SrcLoc
+
+ | RecConDecl name
+ [(name, BangType name)] -- list of "fields"
+ SrcLoc
+
+ | NewConDecl name -- newtype con decl
+ (MonoType name)
+ SrcLoc
+
+data BangType name
+ = Banged (MonoType name)
+ | Unbanged (MonoType name)
+\end{code}
+
+In checking interfaces, we need to ``compare'' @ConDecls@. Use with care!
+\begin{code}
+eqConDecls cons1 cons2
+ = case (cmpList cmp cons1 cons2) of { EQ_ -> True; _ -> False }
+ where
+ cmp (ConDecl n1 tys1 _) (ConDecl n2 tys2 _)
+ = case cmpProtoName n1 n2 of
+ EQ_ -> cmpList cmp_bang_ty tys1 tys2
+ xxx -> xxx
+ cmp (ConOpDecl _ _ _ _) _ = panic# "eqConDecls:ConOpDecl"
+ cmp (RecConDecl _ _ _) _ = panic# "eqConDecls:RecConDecl"
+ cmp (NewConDecl _ _ _) _ = panic# "eqConDecls:NewConDecl"
+ -------------
+
+ cmp_ty = cmpMonoType cmpProtoName
+ -------------
+ cmp_bang_ty (Banged ty1) (Banged ty2) = cmp_ty ty1 ty2
+ cmp_bang_ty (Unbanged ty1) (Unbanged ty2) = cmp_ty ty1 ty2
+ cmp_bang_ty (Banged _) _ = LT_
+ cmp_bang_ty _ _ = GT_
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
+
+ ppr sty (ConDecl con tys _)
+ = ppCat [pprNonOp sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
+ ppr sty (ConOpDecl ty1 op ty2 _)
+ = ppCat [ppr_bang sty ty1, pprOp sty op, ppr_bang sty ty2]
+ ppr sty (NewConDecl con ty _)
+ = ppCat [pprNonOp sty con, pprParendMonoType sty ty]
+ ppr sty (RecConDecl con fields _)
+ = ppCat [pprNonOp sty con, ppChar '{',
+ ppInterleave pp'SP (map pp_field fields), ppChar '}']
+ where
+ pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
+
+ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendMonoType sty ty)
+ppr_bang sty (Unbanged ty) = pprParendMonoType sty ty
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[ClassDecl]{A class declaration}
+%* *
+%************************************************************************
+
+\begin{code}
+data ClassDecl tyvar uvar name pat
+ = ClassDecl (Context name) -- context...
+ name -- name of the class
+ name -- the class type variable
+ [Sig name] -- methods' signatures
+ (MonoBinds tyvar uvar name pat) -- default methods
+ (ClassPragmas name)
+ SrcLoc
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => Outputable (ClassDecl tyvar uvar name pat) where
+
+ ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
+ = ppAboves [ppCat [ppStr "class", pprContext sty context, ppr sty clas,
+ ppr sty tyvar, ppStr "where"],
+ -- ToDo: really shouldn't print "where" unless there are sigs
+ ppNest 4 (ppAboves (map (ppr sty) sigs)),
+ ppNest 4 (ppr sty methods),
+ ppNest 4 (ppr sty pragmas)]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)}
+%* *
+%************************************************************************
+
+\begin{code}
+data InstDecl tyvar uvar name pat
+ = InstDecl name -- Class
+
+ (PolyType name) -- Context => Instance-type
+ -- Using a polytype means that the renamer conveniently
+ -- figures out the quantified type variables for us.
+
+ (MonoBinds tyvar uvar name pat)
+
+ Bool -- True <=> This instance decl is from the
+ -- module being compiled; False <=> It is from
+ -- an imported interface.
+
+ FAST_STRING -- The name of the module where the instance decl
+ -- originally came from; easy enough if it's
+ -- the module being compiled; otherwise, the
+ -- info comes from a pragma.
+
+ [Sig name] -- actually user-supplied pragmatic info
+ (InstancePragmas name) -- interface-supplied pragmatic info
+ SrcLoc
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => Outputable (InstDecl tyvar uvar name pat) where
+
+ ppr sty (InstDecl clas ty binds local modname uprags pragmas src_loc)
+ = let
+ (context, inst_ty)
+ = case ty of
+ HsPreForAllTy c t -> (c, t)
+ HsForAllTy _ c t -> (c, t)
+
+ top_matter = ppCat [ppStr "instance", pprContext sty context,
+ ppr sty clas, pprParendMonoType sty inst_ty]
+ in
+ if nullMonoBinds binds && null uprags then
+ ppAbove top_matter (ppNest 4 (ppr sty pragmas))
+ else
+ ppAboves [
+ ppCat [top_matter, ppStr "where"],
+ if null uprags then ppNil else ppNest 4 (ppr sty uprags),
+ ppNest 4 (ppr sty binds),
+ ppNest 4 (ppr sty pragmas) ]
+\end{code}
+
+A type for recording what instances the user wants to specialise;
+called a ``Sig'' because it's sort of like a ``type signature'' for an
+instance.
+\begin{code}
+data SpecInstSig name
+ = SpecInstSig name -- class
+ (MonoType name) -- type to specialise to
+ SrcLoc
+
+instance (NamedThing name, Outputable name)
+ => Outputable (SpecInstSig name) where
+
+ ppr sty (SpecInstSig clas ty _)
+ = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[DefaultDecl]{A @default@ declaration}
+%* *
+%************************************************************************
+
+There can only be one default declaration per module, but it is hard
+for the parser to check that; we pass them all through in the abstract
+syntax, and that restriction must be checked in the front end.
+
+\begin{code}
+data DefaultDecl name
+ = DefaultDecl [MonoType name]
+ SrcLoc
+
+instance (NamedThing name, Outputable name)
+ => Outputable (DefaultDecl name) where
+
+ ppr sty (DefaultDecl tys src_loc)
+ = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys))
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+%
+\section[HsExpr]{Abstract Haskell syntax: expressions}
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsExpr where
+
+import Ubiq{-uitous-}
+import HsLoop -- for paranoia checking
+
+-- friends:
+import HsBinds ( HsBinds )
+import HsLit ( HsLit )
+import HsMatches ( pprMatches, pprMatch, Match )
+import HsTypes ( PolyType )
+
+-- others:
+import Id ( DictVar(..), GenId, Id(..) )
+import Outputable
+import PprType ( pprType, pprParendType, GenType{-instance-}, GenTyVar{-instance-} )
+import Pretty
+import PprStyle ( PprStyle(..) )
+import SrcLoc ( SrcLoc )
+import TyVar ( GenTyVar{-instances-} )
+import Usage ( GenUsage{-instance-} )
+import Unique ( Unique{-instances-} )
+import Util ( panic{-ToDo:rm eventually-} )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Expressions proper}
+%* *
+%************************************************************************
+
+\begin{code}
+data HsExpr tyvar uvar id pat
+ = HsVar id -- variable
+ | HsLit HsLit -- literal
+ | HsLitOut HsLit -- TRANSLATION
+ (GenType tyvar uvar) -- (with its type)
+
+ | HsLam (Match tyvar uvar id pat) -- lambda
+ | HsApp (HsExpr tyvar uvar id pat) -- application
+ (HsExpr tyvar uvar id pat)
+
+ -- Operator applications and sections.
+ -- NB Bracketed ops such as (+) come out as Vars.
+
+ | OpApp (HsExpr tyvar uvar id pat) -- left operand
+ (HsExpr tyvar uvar id pat) -- operator
+ (HsExpr tyvar uvar id pat) -- right operand
+
+ -- ADR Question? Why is the "op" in a section an expr when it will
+ -- have to be of the form (HsVar op) anyway?
+ -- WDP Answer: But when the typechecker gets ahold of it, it may
+ -- apply the var to a few types; it will then be an expression.
+
+ | SectionL (HsExpr tyvar uvar id pat) -- operand
+ (HsExpr tyvar uvar id pat) -- operator
+ | SectionR (HsExpr tyvar uvar id pat) -- operator
+ (HsExpr tyvar uvar id pat) -- operand
+
+
+ | HsCase (HsExpr tyvar uvar id pat)
+ [Match tyvar uvar id pat] -- must have at least one Match
+ SrcLoc
+
+ | HsIf (HsExpr tyvar uvar id pat) -- predicate
+ (HsExpr tyvar uvar id pat) -- then part
+ (HsExpr tyvar uvar id pat) -- else part
+ SrcLoc
+
+ | HsLet (HsBinds tyvar uvar id pat) -- let(rec)
+ (HsExpr tyvar uvar id pat)
+
+ | 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
+ SrcLoc
+
+ | ListComp (HsExpr tyvar uvar id pat) -- list comprehension
+ [Qual tyvar uvar id pat] -- at least one Qual(ifier)
+
+ | ExplicitList -- syntactic list
+ [HsExpr tyvar uvar id pat]
+ | ExplicitListOut -- TRANSLATION
+ (GenType tyvar uvar) -- Gives type of components of list
+ [HsExpr tyvar uvar id pat]
+
+ | ExplicitTuple -- tuple
+ [HsExpr tyvar uvar id pat]
+ -- NB: Unit is ExplicitTuple []
+ -- for tuples, we can get the types
+ -- direct from the components
+
+ | RecordCon id -- record construction
+ [(id, Maybe (HsExpr tyvar uvar id pat))]
+
+ | RecordUpd (HsExpr tyvar uvar id pat) -- record update
+ [(id, Maybe (HsExpr tyvar uvar id pat))]
+
+ | ExprWithTySig -- signature binding
+ (HsExpr tyvar uvar id pat)
+ (PolyType id)
+ | ArithSeqIn -- arithmetic sequence
+ (ArithSeqInfo tyvar uvar id pat)
+ | ArithSeqOut
+ (HsExpr tyvar uvar id pat) -- (typechecked, of course)
+ (ArithSeqInfo tyvar uvar id pat)
+
+ | CCall FAST_STRING -- call into the C world; string is
+ [HsExpr tyvar uvar id pat] -- the C function; exprs are the
+ -- arguments to pass.
+ Bool -- True <=> might cause Haskell
+ -- garbage-collection (must generate
+ -- more paranoid code)
+ Bool -- True <=> it's really a "casm"
+ -- NOTE: this CCall is the *boxed*
+ -- version; the desugarer will convert
+ -- it into the unboxed "ccall#".
+ (GenType tyvar uvar) -- The result type; will be *bottom*
+ -- until the typechecker gets ahold of it
+
+ | HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation
+ (HsExpr tyvar uvar id pat) -- expr whose cost is to be measured
+\end{code}
+
+Everything from here on appears only in typechecker output.
+
+\begin{code}
+ | TyLam -- TRANSLATION
+ [tyvar]
+ (HsExpr tyvar uvar id pat)
+ | TyApp -- TRANSLATION
+ (HsExpr tyvar uvar id pat) -- generated by Spec
+ [GenType tyvar uvar]
+
+ -- DictLam and DictApp are "inverses"
+ | DictLam
+ [id]
+ (HsExpr tyvar uvar id pat)
+ | DictApp
+ (HsExpr tyvar uvar id pat)
+ [id]
+
+ -- ClassDictLam and Dictionary are "inverses" (see note below)
+ | ClassDictLam
+ [id] -- superclass dicts
+ [id] -- methods
+ (HsExpr tyvar uvar id pat)
+ | Dictionary
+ [id] -- superclass dicts
+ [id] -- methods
+
+ | SingleDict -- a simple special case of Dictionary
+ id -- local dictionary name
+\end{code}
+
+A @Dictionary@, unless of length 0 or 1, becomes a tuple. A
+@ClassDictLam dictvars methods expr@ is, therefore:
+\begin{verbatim}
+\ x -> case x of ( dictvars-and-methods-tuple ) -> expr
+\end{verbatim}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (HsExpr tyvar uvar id pat) where
+ ppr = pprExpr
+\end{code}
+
+\begin{code}
+pprExpr sty (HsVar v)
+ = (if (isOpLexeme v) then ppParens else id) (ppr sty v)
+
+pprExpr sty (HsLit lit) = ppr sty lit
+pprExpr sty (HsLitOut lit _) = ppr sty lit
+
+pprExpr sty (HsLam match)
+ = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)]
+
+pprExpr sty expr@(HsApp e1 e2)
+ = let (fun, args) = collect_args expr [] in
+ ppHang (pprParendExpr sty fun) 4 (ppSep (map (pprParendExpr sty) args))
+ where
+ collect_args (HsApp fun arg) args = collect_args fun (arg:args)
+ collect_args fun args = (fun, args)
+
+pprExpr sty (OpApp e1 op e2)
+ = case op of
+ HsVar v -> pp_infixly v
+ _ -> pp_prefixly
+ where
+ pp_e1 = pprParendExpr sty e1
+ pp_e2 = pprParendExpr sty e2
+
+ pp_prefixly
+ = ppHang (pprParendExpr sty op) 4 (ppSep [pp_e1, pp_e2])
+
+ pp_infixly v
+ = ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]]
+
+pprExpr sty (SectionL expr op)
+ = case op of
+ HsVar v -> pp_infixly v
+ _ -> pp_prefixly
+ where
+ pp_expr = pprParendExpr sty expr
+
+ pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op])
+ 4 (ppCat [pp_expr, ppStr "_x )"])
+ pp_infixly v
+ = ppSep [ ppBeside ppLparen pp_expr,
+ ppBeside (pprOp sty v) ppRparen ]
+
+pprExpr sty (SectionR op expr)
+ = case op of
+ HsVar v -> pp_infixly v
+ _ -> pp_prefixly
+ where
+ pp_expr = pprParendExpr sty expr
+
+ pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")])
+ 4 (ppBeside pp_expr ppRparen)
+ pp_infixly v
+ = ppSep [ ppBeside ppLparen (pprOp sty v),
+ ppBeside pp_expr ppRparen ]
+
+pprExpr sty (CCall fun args _ is_asm result_ty)
+ = ppHang (if is_asm
+ then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"]
+ else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun))
+ 4 (ppSep (map (pprParendExpr sty) args))
+
+pprExpr sty (HsSCC label expr)
+ = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']),
+ pprParendExpr sty expr ]
+
+pprExpr sty (HsCase expr matches _)
+ = ppSep [ ppSep [ppPStr SLIT("case"), ppNest 4 (pprExpr sty expr), ppPStr SLIT("of")],
+ ppNest 2 (pprMatches sty (True, ppNil) matches) ]
+
+pprExpr sty (ListComp expr quals)
+ = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
+ 4 (ppSep [interpp'SP sty quals, ppRbrack])
+
+-- special case: let ... in let ...
+pprExpr sty (HsLet binds expr@(HsLet _ _))
+ = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppCat [ppr sty binds, ppPStr SLIT("in")]),
+ ppr sty expr]
+
+pprExpr sty (HsLet binds expr)
+ = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds),
+ ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)]
+
+pprExpr sty (HsDo stmts _)
+ = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)]
+
+pprExpr sty (HsIf e1 e2 e3 _)
+ = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")],
+ ppNest 4 (pprExpr sty e2),
+ ppPStr SLIT("else"),
+ ppNest 4 (pprExpr sty e3)]
+
+pprExpr sty (ExplicitList exprs)
+ = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs))
+pprExpr sty (ExplicitListOut ty exprs)
+ = ppBesides [ ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)),
+ ifnotPprForUser sty (ppBeside ppSP (ppParens (pprType sty ty))) ]
+
+pprExpr sty (ExplicitTuple exprs)
+ = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs))
+pprExpr sty (ExprWithTySig expr sig)
+ = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")])
+ 4 (ppBeside (ppr sty sig) ppRparen)
+
+pprExpr sty (RecordCon con rbinds)
+ = pp_rbinds sty (ppr sty con) rbinds
+
+pprExpr sty (RecordUpd aexp rbinds)
+ = pp_rbinds sty (pprParendExpr sty aexp) rbinds
+
+pprExpr sty (ArithSeqIn info)
+ = ppBracket (ppr sty info)
+pprExpr sty (ArithSeqOut expr info)
+ = case sty of
+ PprForUser ->
+ ppBracket (ppr sty info)
+ _ ->
+ ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack]
+
+pprExpr sty (TyLam tyvars expr)
+ = ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"])
+ 4 (pprExpr sty expr)
+
+pprExpr sty (TyApp expr [ty])
+ = ppHang (pprExpr sty expr) 4 (pprParendType sty ty)
+
+pprExpr sty (TyApp expr tys)
+ = ppHang (pprExpr sty expr)
+ 4 (ppBracket (interpp'SP sty tys))
+
+pprExpr sty (DictLam dictvars expr)
+ = ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"])
+ 4 (pprExpr sty expr)
+
+pprExpr sty (DictApp expr [dname])
+ = ppHang (pprExpr sty expr) 4 (ppr sty dname)
+
+pprExpr sty (DictApp expr dnames)
+ = ppHang (pprExpr sty expr)
+ 4 (ppBracket (interpp'SP sty dnames))
+
+pprExpr sty (ClassDictLam dicts methods expr)
+ = ppHang (ppCat [ppStr "\\{-classdict-}",
+ ppBracket (interppSP sty dicts),
+ ppBracket (interppSP sty methods),
+ ppStr "->"])
+ 4 (pprExpr sty expr)
+
+pprExpr sty (Dictionary dicts methods)
+ = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
+ ppBracket (interpp'SP sty dicts),
+ ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
+
+pprExpr sty (SingleDict dname)
+ = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
+\end{code}
+
+Parenthesize unless very simple:
+\begin{code}
+pprParendExpr :: (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => PprStyle -> HsExpr tyvar uvar id pat -> Pretty
+
+pprParendExpr sty expr
+ = let
+ pp_as_was = pprExpr sty expr
+ in
+ case expr of
+ HsLit l -> ppr sty l
+ HsLitOut l _ -> ppr sty l
+ HsVar _ -> pp_as_was
+ ExplicitList _ -> pp_as_was
+ ExplicitListOut _ _ -> pp_as_was
+ ExplicitTuple _ -> pp_as_was
+ _ -> ppParens pp_as_was
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Record binds}
+%* *
+%************************************************************************
+
+\begin{code}
+pp_rbinds sty thing rbinds
+ = ppHang thing 4
+ (ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}'])
+
+pp_rbind :: (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => PprStyle -> (id, Maybe (HsExpr tyvar uvar id pat)) -> Pretty
+
+pp_rbind sty (v, Nothing) = ppr sty v
+pp_rbind sty (v, Just e) = ppCat [ppr sty v, ppStr "<-", ppr sty e]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Do stmts}
+%* *
+%************************************************************************
+
+\begin{code}
+data Stmt tyvar uvar id pat
+ = BindStmt pat
+ (HsExpr tyvar uvar id pat)
+ SrcLoc
+ | ExprStmt (HsExpr tyvar uvar id pat)
+ SrcLoc
+ | LetStmt (HsBinds tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (Stmt tyvar uvar id pat) where
+ ppr sty (BindStmt pat expr _)
+ = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
+ ppr sty (LetStmt binds)
+ = ppCat [ppPStr SLIT("let"), ppr sty binds]
+ ppr sty (ExprStmt expr _)
+ = ppr sty expr
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Enumerations and list comprehensions}
+%* *
+%************************************************************************
+
+\begin{code}
+data ArithSeqInfo tyvar uvar id pat
+ = From (HsExpr tyvar uvar id pat)
+ | FromThen (HsExpr tyvar uvar id pat)
+ (HsExpr tyvar uvar id pat)
+ | FromTo (HsExpr tyvar uvar id pat)
+ (HsExpr tyvar uvar id pat)
+ | FromThenTo (HsExpr tyvar uvar id pat)
+ (HsExpr tyvar uvar id pat)
+ (HsExpr tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (ArithSeqInfo tyvar uvar id pat) where
+ ppr sty (From e1) = ppBesides [ppr sty e1, pp_dotdot]
+ ppr sty (FromThen e1 e2) = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot]
+ ppr sty (FromTo e1 e3) = ppBesides [ppr sty e1, pp_dotdot, ppr sty e3]
+ ppr sty (FromThenTo e1 e2 e3)
+ = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot, ppr sty e3]
+
+pp_dotdot = ppPStr SLIT(" .. ")
+\end{code}
+
+``Qualifiers'' in list comprehensions:
+\begin{code}
+data Qual tyvar uvar id pat
+ = GeneratorQual pat
+ (HsExpr tyvar uvar id pat)
+ | LetQual (HsBinds tyvar uvar id pat)
+ | FilterQual (HsExpr tyvar uvar id pat)
+\end{code}
+
+\begin{code}
+instance (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (Qual tyvar uvar id pat) where
+ ppr sty (GeneratorQual pat expr)
+ = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
+ ppr sty (LetQual binds)
+ = ppCat [ppPStr SLIT("let"), ppr sty binds]
+ ppr sty (FilterQual expr)
+ = ppr sty expr
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsImpExp]{Abstract syntax: imports, exports, interfaces}
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsImpExp where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsDecls ( FixityDecl, TyDecl, ClassDecl, InstDecl )
+import HsBinds ( Sig )
+
+-- others:
+import Outputable
+import PprStyle ( PprStyle(..) )
+import Pretty
+import SrcLoc ( SrcLoc{-instances-} )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Import and export declaration lists}
+%* *
+%************************************************************************
+
+One per \tr{import} declaration in a module.
+\begin{code}
+data ImportedInterface tyvar uvar name pat
+ = ImportMod (Interface tyvar uvar name pat)
+ Bool -- qualified?
+ (Maybe FAST_STRING) -- as Modid
+ (Maybe (Bool, [IE name])) -- (hiding?, names)
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => Outputable (ImportedInterface tyvar uvar name pat) where
+
+ ppr sty (ImportMod iface qual as spec)
+ = ppAbove (ppHang (ppCat [ppStr "import", pp_qual qual, ppr PprForUser iface, pp_as as])
+ 4 (pp_spec spec))
+ (case sty of {PprForUser -> ppNil; _ -> ppr sty iface})
+ where
+ pp_qual False = ppNil
+ pp_qual True = ppStr "qualified"
+
+ pp_as Nothing = ppNil
+ pp_as (Just a) = ppCat [ppStr "as", ppPStr a]
+
+ pp_spec Nothing = ppNil
+ pp_spec (Just (False, spec))
+ = ppBesides [ppStr "(", interpp'SP sty spec, ppStr ")"]
+ pp_spec (Just (True, spec))
+ = ppBesides [ppStr "hiding (", interpp'SP sty spec, ppStr ")"]
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Imported and exported entities}
+%* *
+%************************************************************************
+\begin{code}
+data IE name
+ = IEVar name
+ | IEThingAbs name -- Constructor/Type/Class (can't tell)
+ | IEThingAll name -- Class/Type plus all methods/constructors
+ | IEThingWith name [name] -- Class/Type plus some methods/constructors
+ | IEModuleContents FAST_STRING -- (Export Only)
+\end{code}
+
+\begin{code}
+instance (Outputable name) => Outputable (IE name) where
+ ppr sty (IEVar var) = ppr 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]
+ ppr sty (IEModuleContents mod)
+ = ppBeside (ppPStr SLIT("module ")) (ppPStr mod)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Interfaces}
+%* *
+%************************************************************************
+
+\begin{code}
+data Interface tyvar uvar name pat
+ = Interface FAST_STRING -- module name
+ [IfaceImportDecl name]
+ [FixityDecl name]
+ [TyDecl name] -- data decls may have no constructors
+ [ClassDecl tyvar uvar name pat] -- without default methods
+ [InstDecl tyvar uvar name pat] -- without method defns
+ [Sig name]
+ SrcLoc
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => Outputable (Interface tyvar uvar name pat) where
+
+ ppr PprForUser (Interface name _ _ _ _ _ _ _) = ppPStr name
+
+ ppr sty (Interface name iimpdecls fixities tydecls classdecls instdecls sigs anns)
+ = ppAboves [ppStr "{-",
+ ifPprShowAll sty (ppr sty anns),
+ ppCat [ppStr "interface", ppPStr name, ppStr "where"],
+ ppNest 4 (ppAboves [
+ pp_nonnull iimpdecls,
+ pp_nonnull fixities,
+ pp_nonnull tydecls,
+ pp_nonnull classdecls,
+ pp_nonnull instdecls,
+ pp_nonnull sigs]),
+ ppStr "-}"]
+ where
+ pp_nonnull [] = ppNil
+ pp_nonnull xs = ppAboves (map (ppr sty) xs)
+\end{code}
+
+\begin{code}
+data IfaceImportDecl name
+ = IfaceImportDecl FAST_STRING -- module we're being told about
+ [IE name] -- things we're being told about
+ SrcLoc
+\end{code}
+
+\begin{code}
+instance Outputable name => Outputable (IfaceImportDecl name) where
+
+ ppr sty (IfaceImportDecl mod names src_loc)
+ = ppHang (ppCat [ppPStr SLIT("import"), ppPStr mod, ppLparen])
+ 4 (ppSep [ppCat [interpp'SP sty names, ppRparen]])
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsLit]{Abstract syntax: source-language literals}
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsLit where
+
+import Ubiq{-uitous-}
+
+import Pretty
+\end{code}
+
+\begin{code}
+data HsLit
+ = HsChar Char -- characters
+ | HsCharPrim Char -- unboxed char literals
+ | HsString FAST_STRING -- strings
+ | HsStringPrim FAST_STRING -- packed string
+
+ | HsInt Integer -- integer-looking literals
+ | HsFrac Rational -- frac-looking literals
+ -- Up through dict-simplification, HsInt and HsFrac simply
+ -- mean the literal was integral- or fractional-looking; i.e.,
+ -- whether it had an explicit decimal-point in it. *After*
+ -- dict-simplification, they mean (boxed) "Integer" and
+ -- "Rational" [Ratio Integer], respectively.
+
+ -- Dict-simplification tries to replace such lits w/ more
+ -- specific ones, using the unboxed variants that follow...
+ | HsIntPrim Integer -- unboxed Int literals
+ | HsFloatPrim Rational -- unboxed Float literals
+ | HsDoublePrim Rational -- unboxed Double literals
+
+ | HsLitLit FAST_STRING -- to pass ``literal literals'' through to C
+ -- also: "overloaded" type; but
+ -- must resolve to boxed-primitive!
+ -- (WDP 94/10)
+\end{code}
+
+\begin{code}
+negLiteral (HsInt i) = HsInt (-i)
+negLiteral (HsFrac f) = HsFrac (-f)
+\end{code}
+
+\begin{code}
+instance Outputable HsLit where
+ ppr sty (HsChar c) = ppStr (show c)
+ ppr sty (HsCharPrim c) = ppBeside (ppStr (show c)) (ppChar '#')
+ ppr sty (HsString s) = ppStr (show s)
+ ppr sty (HsStringPrim s) = ppBeside (ppStr (show s)) (ppChar '#')
+ ppr sty (HsInt i) = ppInteger i
+ ppr sty (HsFrac f) = ppRational f
+ ppr sty (HsFloatPrim f) = ppBeside (ppRational f) (ppChar '#')
+ ppr sty (HsDoublePrim d) = ppBeside (ppRational d) (ppStr "##")
+ ppr sty (HsIntPrim i) = ppBeside (ppInteger i) (ppChar '#')
+ ppr sty (HsLitLit s) = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
+\end{code}
--- /dev/null
+\begin{code}
+
+interface HsLoop where
+
+import HsExpr( HsExpr )
+import Outputable( NamedThing, Outputable )
+import HsBinds ( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds )
+import HsDecls ( ConDecl )
+
+-- HsExpr outputs
+data HsExpr tyvar uvar id pat
+
+instance (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => Outputable (HsExpr tyvar uvar id pat)
+
+
+-- HsBinds outputs
+data Sig id
+instance (NamedThing name, Outputable name) => Outputable (Sig name)
+
+data Bind tyvar uvar id pat
+
+data HsBinds tyvar uvar id pat
+
+instance (Outputable pat, NamedThing id, Outputable id,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (HsBinds tyvar uvar id pat)
+
+data MonoBinds tyvar uvar id pat
+
+instance (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ Outputable (MonoBinds tyvar uvar id pat)
+
+nullBinds :: HsBinds tyvar uvar id pat -> Bool
+nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
+
+-- HsDecls outputs
+data ConDecl name
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides}
+
+The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsMatches where
+
+import Ubiq{-uitous-}
+
+import HsLoop ( HsExpr, nullBinds, HsBinds )
+import Outputable ( ifPprShowAll )
+import PprType
+import Pretty
+import SrcLoc ( SrcLoc{-instances-} )
+import TyVar ( GenTyVar{-instances-} )
+import Unique ( Unique{-instances-} )
+import Util ( panic )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@Match@, @GRHSsAndBinds@, and @GRHS@ datatypes}
+%* *
+%************************************************************************
+
+@Match@es are sets of pattern bindings and right hand sides for
+functions, patterns or case branches. For example, if a function @g@
+is defined as:
+\begin{verbatim}
+g (x,y) = y
+g ((x:ys),y) = y+1,
+\end{verbatim}
+then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
+
+It is always the case that each element of an @[Match]@ list has the
+same number of @PatMatch@s inside it. This corresponds to saying that
+a function defined by pattern matching must have the same number of
+patterns in each equation.
+
+\begin{code}
+data Match tyvar uvar id pat
+ = PatMatch pat
+ (Match tyvar uvar id pat)
+ | GRHSMatch (GRHSsAndBinds tyvar uvar id pat)
+\end{code}
+
+Sets of guarded right hand sides (GRHSs). In:
+\begin{verbatim}
+f (x,y) | x==True = y
+ | otherwise = y*2
+\end{verbatim}
+a guarded right hand side is either
+@(x==True = y)@, or @(otherwise = y*2)@.
+
+For each match, there may be several guarded right hand
+sides, as the definition of @f@ shows.
+
+\begin{code}
+data GRHSsAndBinds tyvar uvar id pat
+ = GRHSsAndBindsIn [GRHS tyvar uvar id pat] -- at least one GRHS
+ (HsBinds tyvar uvar id pat)
+
+ | GRHSsAndBindsOut [GRHS tyvar uvar id pat] -- at least one GRHS
+ (HsBinds tyvar uvar id pat)
+ (GenType tyvar uvar)
+
+data GRHS tyvar uvar id pat
+ = GRHS (HsExpr tyvar uvar id pat) -- guard(ed)...
+ (HsExpr tyvar uvar id pat) -- ... right-hand side
+ SrcLoc
+
+ | OtherwiseGRHS (HsExpr tyvar uvar id pat) -- guard-free
+ SrcLoc
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Printing}
+%* *
+%************************************************************************
+
+We know the list must have at least one @Match@ in it.
+\begin{code}
+pprMatches :: (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ PprStyle -> (Bool, Pretty) -> [Match tyvar uvar id pat] -> Pretty
+
+pprMatches sty print_info@(is_case, name) [match]
+ = if is_case then
+ pprMatch sty is_case match
+ else
+ ppHang name 4 (pprMatch sty is_case match)
+
+pprMatches sty print_info (match1 : rest)
+ = ppAbove (pprMatches sty print_info [match1])
+ (pprMatches sty print_info rest)
+
+---------------------------------------------
+pprMatch :: (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
+ PprStyle -> Bool -> Match tyvar uvar id pat -> Pretty
+
+pprMatch sty is_case first_match
+ = ppHang (ppSep (map (ppr sty) row_of_pats))
+ 8 grhss_etc_stuff
+ where
+ (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match
+
+ ppr_match sty is_case (PatMatch pat match)
+ = (pat:pats, grhss_stuff)
+ where
+ (pats, grhss_stuff) = ppr_match sty is_case match
+
+ ppr_match sty is_case (GRHSMatch grhss_n_binds)
+ = ([], pprGRHSsAndBinds sty is_case grhss_n_binds)
+
+----------------------------------------------------------
+
+pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds)
+ = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
+ (if (nullBinds binds)
+ then ppNil
+ else ppAboves [ ppStr "where", ppNest 4 (ppr sty binds) ])
+
+pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty)
+ = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
+ (if (nullBinds binds)
+ then ppNil
+ else ppAboves [ ifPprShowAll sty
+ (ppCat [ppStr "{- ty:", ppr sty ty, ppStr "-}"]),
+ ppStr "where", ppNest 4 (ppr sty binds) ])
+
+---------------------------------------------
+pprGRHS :: (NamedThing id, Outputable id, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => PprStyle -> Bool -> GRHS tyvar uvar id pat -> Pretty
+
+pprGRHS sty is_case (GRHS guard expr locn)
+ = ppHang (ppCat [ppChar '|', ppr sty guard, ppStr (if is_case then "->" else "=")])
+ 4 (ppr sty expr)
+
+pprGRHS sty is_case (OtherwiseGRHS expr locn)
+ = ppHang (ppStr (if is_case then "->" else "="))
+ 4 (ppr sty expr)
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[PatSyntax]{Abstract Haskell syntax---patterns}
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsPat (
+ InPat(..),
+ OutPat(..),
+
+ unfailablePats, unfailablePat,
+ patsAreAllCons, isConPat,
+ patsAreAllLits, isLitPat,
+ irrefutablePat,
+ collectPatBinders
+ ) where
+
+import Ubiq
+
+-- friends:
+import HsLit ( HsLit )
+import HsLoop ( HsExpr )
+
+-- others:
+import Id ( GenId, getDataConSig )
+import Maybes ( maybeToBool )
+import Outputable
+import PprStyle ( PprStyle(..) )
+import Pretty
+import TyCon ( maybeTyConSingleCon )
+import TyVar ( GenTyVar )
+import PprType ( GenType, GenTyVar )
+import Unique ( Unique )
+
+\end{code}
+
+Patterns come in distinct before- and after-typechecking flavo(u)rs.
+\begin{code}
+data InPat name
+ = WildPatIn -- wild card
+ | VarPatIn name -- variable
+ | LitPatIn HsLit -- literal
+ | LazyPatIn (InPat name) -- lazy pattern
+ | AsPatIn name -- as pattern
+ (InPat name)
+ | ConPatIn name -- constructed type
+ [InPat name]
+ | ConOpPatIn (InPat name)
+ name
+ (InPat name)
+ | ListPatIn [InPat name] -- syntactic list
+ -- must have >= 1 elements
+ | TuplePatIn [InPat name] -- tuple
+
+ | RecPatIn name -- record
+ [(name, Maybe (InPat name))]
+
+data OutPat tyvar uvar id
+ = WildPat (GenType tyvar uvar) -- wild card
+
+ | VarPat id -- variable (type is in the Id)
+
+ | LazyPat (OutPat tyvar uvar id) -- lazy pattern
+
+ | AsPat id -- as pattern
+ (OutPat tyvar uvar id)
+
+ | ConPat Id -- Constructor is always an Id
+ (GenType tyvar uvar) -- the type of the pattern
+ [(OutPat tyvar uvar id)]
+
+ | ConOpPat (OutPat tyvar uvar id) -- just a special case...
+ Id
+ (OutPat tyvar uvar id)
+ (GenType tyvar uvar)
+ | ListPat -- syntactic list
+ (GenType tyvar uvar) -- the type of the elements
+ [(OutPat tyvar uvar id)]
+
+ | TuplePat [(OutPat tyvar uvar id)] -- tuple
+ -- UnitPat is TuplePat []
+
+ | RecPat id -- record
+ [(id, Maybe (OutPat tyvar uvar id))]
+
+ | LitPat -- Used for *non-overloaded* literal patterns:
+ -- Int#, Char#, Int, Char, String, etc.
+ HsLit
+ (GenType tyvar uvar) -- type of pattern
+
+ | NPat -- Used for *overloaded* literal patterns
+ HsLit -- the literal is retained so that
+ -- the desugarer can readily identify
+ -- equations with identical literal-patterns
+ (GenType tyvar uvar) -- type of pattern, t
+ (HsExpr tyvar uvar id (OutPat tyvar uvar id))
+ -- of type t -> Bool; detects match
+
+ | DictPat -- Used when destructing Dictionaries with an explicit case
+ [id] -- superclass dicts
+ [id] -- methods
+\end{code}
+
+\begin{code}
+instance (Outputable name, NamedThing name) => Outputable (InPat name) where
+ ppr = pprInPat
+
+pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty
+
+pprInPat sty (WildPatIn) = ppStr "_"
+pprInPat sty (VarPatIn var) = pprNonOp sty var
+pprInPat sty (LitPatIn s) = ppr sty s
+pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat)
+pprInPat sty (AsPatIn name pat)
+ = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
+
+pprInPat sty (ConPatIn c pats)
+ = if null pats then
+ ppr sty c
+ else
+ ppBesides [ppLparen, ppr sty c, ppSP, interppSP sty pats, ppRparen]
+
+
+pprInPat sty (ConOpPatIn pat1 op pat2)
+ = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen]
+
+-- ToDo: use pprOp to print op (but this involves fiddling various
+-- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
+
+pprInPat sty (ListPatIn pats)
+ = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
+pprInPat sty (TuplePatIn pats)
+ = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
+
+pprInPat sty (RecPatIn con rpats)
+ = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
+ where
+ pp_rpat (v, Nothing) = ppr sty v
+ pp_rpat (v, Just p) = ppCat [ppr sty v, ppStr "<-", ppr sty p]
+\end{code}
+
+\begin{code}
+instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+ NamedThing id, Outputable id)
+ => Outputable (OutPat tyvar uvar id) where
+ ppr = pprOutPat
+\end{code}
+
+\begin{code}
+pprOutPat sty (WildPat ty) = ppChar '_'
+pprOutPat sty (VarPat var) = pprNonOp sty var
+pprOutPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat]
+pprOutPat sty (AsPat name pat)
+ = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
+
+pprOutPat sty (ConPat name ty [])
+ = ppBeside (ppr sty name)
+ (ifPprShowAll sty (pprConPatTy sty ty))
+
+pprOutPat sty (ConPat name ty pats)
+ = ppBesides [ppLparen, ppr sty name, ppSP,
+ interppSP sty pats, ppRparen,
+ ifPprShowAll sty (pprConPatTy sty ty) ]
+
+pprOutPat sty (ConOpPat pat1 op pat2 ty)
+ = ppBesides [ppLparen, ppr sty pat1, ppSP, pprOp sty op, ppSP, ppr sty pat2, ppRparen]
+
+pprOutPat sty (ListPat ty pats)
+ = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
+pprOutPat sty (TuplePat pats)
+ = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
+
+pprOutPat sty (RecPat con rpats)
+ = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
+ where
+ pp_rpat (v, Nothing) = ppr sty v
+ pp_rpat (v, Just p) = ppBesides [ppr sty v, ppStr "<-", ppr sty p]
+
+pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more
+pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more
+
+pprOutPat sty (DictPat dicts methods)
+ = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
+ ppBracket (interpp'SP sty dicts),
+ ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
+
+pprConPatTy sty ty
+ = ppBesides [ppLparen, ppr sty ty, ppRparen]
+\end{code}
+
+%************************************************************************
+%* *
+%* predicates for checking things about pattern-lists in EquationInfo *
+%* *
+%************************************************************************
+\subsection[Pat-list-predicates]{Look for interesting things in patterns}
+
+Unlike in the Wadler chapter, where patterns are either ``variables''
+or ``constructors,'' here we distinguish between:
+\begin{description}
+\item[unfailable:]
+Patterns that cannot fail to match: variables, wildcards, and lazy
+patterns.
+
+These are the irrefutable patterns; the two other categories
+are refutable patterns.
+
+\item[constructor:]
+A non-literal constructor pattern (see next category).
+
+\item[literal patterns:]
+At least the numeric ones may be overloaded.
+\end{description}
+
+A pattern is in {\em exactly one} of the above three categories; `as'
+patterns are treated specially, of course.
+
+\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
+
+patsAreAllCons :: [OutPat a b c] -> Bool
+patsAreAllCons pat_list = all isConPat pat_list
+
+isConPat (AsPat _ pat) = isConPat pat
+isConPat (ConPat _ _ _) = True
+isConPat (ConOpPat _ _ _ _) = True
+isConPat (ListPat _ _) = True
+isConPat (TuplePat _) = True
+isConPat (DictPat ds ms) = (length ds + length ms) > 1
+isConPat other = False
+
+patsAreAllLits :: [OutPat a b c] -> Bool
+patsAreAllLits pat_list = all isLitPat pat_list
+
+isLitPat (AsPat _ pat) = isLitPat pat
+isLitPat (LitPat _ _) = True
+isLitPat (NPat _ _ _) = True
+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) = all irrefutablePat pats && only_con con
+irrefutablePat (ConOpPat pat1 con pat2 _) = irrefutablePat pat1 && irrefutablePat pat1 && only_con con
+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) = getDataConSig 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@.
+\begin{code}
+collectPatBinders :: InPat a -> [a]
+
+collectPatBinders (VarPatIn var) = [var]
+collectPatBinders (LazyPatIn pat) = collectPatBinders pat
+collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
+collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
+collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2
+collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
+collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats)
+collectPatBinders any_other_pat = [ {-no binders-} ]
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+%
+%************************************************************************
+%* *
+\section[HsPragmas]{Pragmas in Haskell interface files}
+%* *
+%************************************************************************
+
+See also: @Sig@ (``signatures'') which is where user-supplied pragmas
+for values show up; ditto @SpecInstSig@ (for instances) and
+@SpecDataSig@ (for data types and type synonyms).
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsPragmas where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsLoop ( ConDecl )
+import HsCore ( UnfoldingCoreExpr )
+import HsTypes ( MonoType )
+
+-- others:
+import IdInfo
+import Outputable ( Outputable(..){-instances-} )
+import Pretty
+\end{code}
+
+Certain pragmas expect to be pinned onto certain constructs.
+
+Pragma types may be parameterised, just as with any other
+abstract-syntax type.
+
+For a @data@ declaration---makes visible the constructors for an
+abstract @data@ type and indicates which specialisations exist.
+\begin{code}
+data DataPragmas name
+ = DataPragmas [ConDecl name] -- hidden data constructors
+ [[Maybe (MonoType name)]] -- types to which specialised
+\end{code}
+
+These are {\em general} things you can know about any value:
+\begin{code}
+data GenPragmas name
+ = NoGenPragmas
+ | GenPragmas (Maybe Int) -- arity (maybe)
+ (Maybe UpdateInfo) -- update info (maybe)
+ DeforestInfo -- deforest info
+ (ImpStrictness name) -- strictness, worker-wrapper
+ (ImpUnfolding name) -- unfolding (maybe)
+ [([Maybe (MonoType name)], -- Specialisations: types to which spec'd;
+ Int, -- # dicts to ignore
+ GenPragmas name)] -- Gen info about the spec'd version
+
+noGenPragmas = NoGenPragmas
+
+data ImpUnfolding name
+ = NoImpUnfolding
+ | ImpMagicUnfolding FAST_STRING -- magic "unfolding"
+ -- known to the compiler by "String"
+ | ImpUnfolding UnfoldingGuidance -- always, if you like, etc.
+ (UnfoldingCoreExpr name)
+
+data ImpStrictness name
+ = NoImpStrictness
+ | ImpStrictness Bool -- True <=> bottoming Id
+ [Demand] -- demand info
+ (GenPragmas name) -- about the *worker*
+\end{code}
+
+For an ordinary imported function: it can have general pragmas (only).
+
+For a class's super-class dictionary selectors:
+\begin{code}
+data ClassPragmas name
+ = NoClassPragmas
+ | SuperDictPragmas [GenPragmas name] -- list mustn't be empty
+\end{code}
+
+For a class's method selectors:
+\begin{code}
+data ClassOpPragmas name
+ = NoClassOpPragmas
+ | ClassOpPragmas (GenPragmas name) -- for method selector
+ (GenPragmas name) -- for default method
+
+noClassOpPragmas = NoClassOpPragmas
+\end{code}
+
+\begin{code}
+data InstancePragmas name
+ = NoInstancePragmas
+
+ | SimpleInstancePragma -- nothing but for the dfun itself...
+ (GenPragmas name)
+
+ | ConstantInstancePragma
+ (GenPragmas name) -- for the "dfun" itself
+ [(name, GenPragmas name)] -- one per class op
+
+ | SpecialisedInstancePragma
+ (GenPragmas name) -- for its "dfun"
+ [([Maybe (MonoType name)], -- specialised instance; type...
+ Int, -- #dicts to ignore
+ InstancePragmas name)] -- (no SpecialisedInstancePragma please!)
+\end{code}
+
+Some instances for printing (just for debugging, really)
+\begin{code}
+instance Outputable name => Outputable (ClassPragmas name) where
+ ppr sty NoClassPragmas = ppNil
+ ppr sty (SuperDictPragmas sdsel_prags)
+ = ppAbove (ppStr "{-superdict pragmas-}")
+ (ppr sty sdsel_prags)
+
+instance Outputable name => Outputable (ClassOpPragmas name) where
+ ppr sty NoClassOpPragmas = ppNil
+ ppr sty (ClassOpPragmas op_prags defm_prags)
+ = ppAbove (ppCat [ppStr "{-meth-}", ppr sty op_prags])
+ (ppCat [ppStr "{-defm-}", ppr sty defm_prags])
+
+instance Outputable name => Outputable (InstancePragmas name) where
+ ppr sty NoInstancePragmas = ppNil
+ ppr sty (SimpleInstancePragma dfun_pragmas)
+ = ppCat [ppStr "{-dfun-}", ppr sty dfun_pragmas]
+ ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs)
+ = ppAbove (ppCat [ppStr "{-constm-}", ppr sty dfun_pragmas])
+ (ppAboves (map pp_pair name_pragma_pairs))
+ where
+ pp_pair (n, prags)
+ = ppCat [ppr sty n, ppEquals, ppr sty prags]
+
+ ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info)
+ = ppAbove (ppCat [ppStr "{-spec'd-}", ppr sty dfun_pragmas])
+ (ppAboves (map pp_info spec_pragma_info))
+ where
+ pp_info (ty_maybes, num_dicts, prags)
+ = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack,
+ ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags]
+ pp_ty Nothing = ppStr "_N_"
+ pp_ty (Just t)= ppr sty t
+
+instance Outputable name => Outputable (GenPragmas name) where
+ ppr sty NoGenPragmas = ppNil
+ ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs)
+ = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
+ pp_str strictness, pp_unf unfolding,
+ pp_specs specs]
+ where
+ pp_arity Nothing = ppNil
+ pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i)
+
+ pp_upd Nothing = ppNil
+ pp_upd (Just u) = ppInfo sty id u
+
+ pp_str NoImpStrictness = ppNil
+ pp_str (ImpStrictness is_bot demands wrkr_prags)
+ = ppBesides [ppStr "IS_BOT=", ppr sty is_bot,
+ ppStr "STRICTNESS=", ppStr (showList demands ""),
+ ppStr " {", ppr sty wrkr_prags, ppStr "}"]
+
+ pp_unf NoImpUnfolding = ppStr "NO_UNFOLDING"
+ pp_unf (ImpMagicUnfolding m) = ppBeside (ppStr "MAGIC=") (ppPStr m)
+ pp_unf (ImpUnfolding g core) = ppBeside (ppStr "UNFOLD=") (ppr sty core)
+
+ pp_specs [] = ppNil
+ pp_specs specs
+ = ppBesides [ppStr "SPECS=[", ppInterleave ppSP (map pp_spec specs), ppStr "]"]
+ where
+ pp_spec (ty_maybes, num_dicts, gprags)
+ = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags]
+
+ pp_MaB Nothing = ppStr "_N_"
+ pp_MaB (Just x) = ppr sty x
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section{Haskell abstract syntax definition}
+
+This module glues together the pieces of the Haskell abstract syntax,
+which is declared in the various \tr{Hs*} modules. This module,
+therefore, is almost nothing but re-exporting.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsSyn (
+
+ -- NB: don't reexport HsCore or HsPragmas;
+ -- this module tells about "real Haskell"
+
+ HsSyn.. ,
+ HsBinds.. ,
+ HsDecls.. ,
+ HsExpr.. ,
+ HsImpExp.. ,
+ HsLit.. ,
+ HsMatches.. ,
+ HsPat.. ,
+ HsTypes..
+
+ ) where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsBinds
+import HsDecls
+import HsExpr
+import HsImpExp
+import HsLit
+import HsMatches
+import HsPat
+import HsTypes
+import HsPragmas ( ClassPragmas, ClassOpPragmas,
+ DataPragmas, GenPragmas, InstancePragmas
+ )
+-- others:
+import FiniteMap ( FiniteMap )
+import Outputable ( ifPprShowAll, interpp'SP, Outputable(..){-instances-} )
+import Pretty
+import SrcLoc ( SrcLoc{-instances-} )
+\end{code}
+
+@Fake@ is a placeholder type; for when tyvars and uvars aren't used.
+\begin{code}
+data Fake = Fake
+instance Eq Fake
+instance Outputable Fake
+\end{code}
+
+All we actually declare here is the top-level structure for a module.
+\begin{code}
+data HsModule tyvar uvar name pat
+ = HsModule
+ FAST_STRING -- module name
+ (Maybe [IE name]) -- export list; Nothing => export everything
+ -- Just [] => export *nothing* (???)
+ -- Just [...] => as you would expect...
+ [ImportedInterface tyvar uvar name pat]
+ -- We snaffle interesting stuff out of the
+ -- imported interfaces early on, adding that
+ -- info to TyDecls/etc; so this list is
+ -- often empty, downstream.
+ [FixityDecl name]
+ [TyDecl name]
+ [SpecDataSig name] -- user pragmas that modify TyDecls
+ [ClassDecl tyvar uvar name pat]
+ [InstDecl tyvar uvar name pat]
+ [SpecInstSig name] -- user pragmas that modify InstDecls
+ [DefaultDecl name]
+ (HsBinds tyvar uvar name pat) -- the main stuff!
+ [Sig name] -- "Sigs" are folded into the "HsBinds"
+ -- pretty early on, so this list is
+ -- often either empty or just the
+ -- interface signatures.
+ SrcLoc
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => Outputable (HsModule tyvar uvar name pat) where
+
+ ppr sty (HsModule name exports imports fixities
+ typedecls typesigs classdecls instdecls instsigs
+ defdecls binds sigs src_loc)
+ = ppAboves [
+ ifPprShowAll sty (ppr sty src_loc),
+ case exports of
+ Nothing -> ppCat [ppPStr SLIT("module"), ppPStr name, ppPStr SLIT("where")]
+ Just es -> ppAboves [
+ ppCat [ppPStr SLIT("module"), ppPStr name, ppLparen],
+ ppNest 8 (interpp'SP sty es),
+ ppNest 4 (ppPStr SLIT(") where"))
+ ],
+ pp_nonnull imports, pp_nonnull fixities,
+ pp_nonnull typedecls, pp_nonnull typesigs,
+ pp_nonnull classdecls,
+ pp_nonnull instdecls, pp_nonnull instsigs,
+ pp_nonnull defdecls,
+ ppr sty binds, pp_nonnull sigs
+ ]
+ where
+ pp_nonnull [] = ppNil
+ pp_nonnull xs = ppAboves (map (ppr sty) xs)
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[HsTypes]{Abstract syntax: user-defined types}
+
+If compiled without \tr{#define COMPILING_GHC}, you get
+(part of) a Haskell-abstract-syntax library. With it,
+you get part of GHC.
+
+\begin{code}
+#include "HsVersions.h"
+
+module HsTypes (
+ PolyType(..), MonoType(..),
+ Context(..), ClassAssertion(..)
+
+#ifdef COMPILING_GHC
+ , cmpPolyType, cmpMonoType
+ , pprParendMonoType, pprContext
+ , extractMonoTyNames, extractCtxtTyNames
+#endif
+ ) where
+
+#ifdef COMPILING_GHC
+import Ubiq{-uitous-}
+
+import Outputable ( interppSP, ifnotPprForUser )
+import Pretty
+import ProtoName ( cmpProtoName, ProtoName )
+import Type ( Kind )
+import Util ( cmpList, panic# )
+
+#endif {- COMPILING_GHC -}
+\end{code}
+
+This is the syntax for types as seen in type signatures.
+
+\begin{code}
+data PolyType name
+ = HsPreForAllTy (Context name)
+ (MonoType name)
+
+ -- The renamer turns HsPreForAllTys into HsForAllTys when they
+ -- occur in signatures, to make the binding of variables
+ -- explicit. This distinction is made visible for
+ -- non-COMPILING_GHC code, because you probably want to do the
+ -- same thing.
+
+ | HsForAllTy [name]
+ (Context name)
+ (MonoType name)
+
+type Context name = [ClassAssertion name]
+
+type ClassAssertion name = (name, name)
+
+data MonoType name
+ = MonoTyVar name -- Type variable
+
+ | MonoTyApp name -- Type constructor or variable
+ [MonoType name]
+
+ -- We *could* have a "MonoTyCon name" equiv to "MonoTyApp name []"
+ -- (for efficiency, what?) WDP 96/02/18
+
+ | MonoFunTy (MonoType name) -- function type
+ (MonoType name)
+
+ | MonoListTy (MonoType name) -- list type
+ | MonoTupleTy [MonoType name] -- tuple type (length gives arity)
+
+#ifdef COMPILING_GHC
+ -- these next two are only used in unfoldings in interfaces
+ | MonoDictTy name -- Class
+ (MonoType name)
+
+ | MonoForAllTy [(name, Kind)]
+ (MonoType name)
+ -- *** NOTA BENE *** A "monotype" in a pragma can have
+ -- for-alls in it, (mostly to do with dictionaries). These
+ -- must be explicitly Kinded.
+
+#endif {- COMPILING_GHC -}
+\end{code}
+
+We do define a specialised equality for these \tr{*Type} types; used
+in checking interfaces. Most any other use is likely to be {\em
+wrong}, so be careful!
+\begin{code}
+#ifdef COMPILING_GHC
+
+cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_
+cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_
+cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_
+
+-- We assume that HsPreForAllTys have been smashed by now.
+# ifdef DEBUG
+cmpPolyType _ (HsPreForAllTy _ _) _ = panic# "cmpPolyType:HsPreForAllTy:1st arg"
+cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg"
+# endif
+
+cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
+ = case (cmp_tvs tvs1 tvs2) of
+ EQ_ -> case (cmpContext cmp c1 c2) of
+ EQ_ -> cmpMonoType cmp t1 t2
+ xxx -> xxx
+ xxx -> xxx
+ where
+ cmp_tvs [] [] = EQ_
+ cmp_tvs [] _ = LT_
+ cmp_tvs _ [] = GT_
+ cmp_tvs (a:as) (b:bs)
+ = case cmp a b of { EQ_ -> cmp_tvs as bs; xxx -> xxx }
+ cmp_tvs _ _ = panic# "cmp_tvs"
+
+-----------
+cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
+ = cmp n1 n2
+
+cmpMonoType cmp (MonoTupleTy tys1) (MonoTupleTy tys2)
+ = cmpList (cmpMonoType cmp) tys1 tys2
+cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2)
+ = cmpMonoType cmp ty1 ty2
+
+cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
+ = case cmp tc1 tc2 of { EQ_ -> cmpList (cmpMonoType cmp) tys1 tys2; xxx -> xxx }
+
+cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
+ = case cmpMonoType cmp a1 a2 of { EQ_ -> cmpMonoType cmp b1 b2; xxx -> xxx }
+
+cmpMonoType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2)
+ = case cmp c1 c2 of { EQ_ -> cmpMonoType cmp ty1 ty2; xxx -> xxx }
+
+cmpMonoType cmp ty1 ty2 -- tags must be different
+ = let tag1 = tag ty1
+ tag2 = tag ty2
+ in
+ if tag1 _LT_ tag2 then LT_ else GT_
+ where
+ tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT)
+ tag (MonoTupleTy tys1) = ILIT(2)
+ tag (MonoListTy ty1) = ILIT(3)
+ tag (MonoTyApp tc1 tys1) = ILIT(4)
+ tag (MonoFunTy a1 b1) = ILIT(5)
+ tag (MonoDictTy c1 ty1) = ILIT(7)
+
+-------------------
+cmpContext cmp a b
+ = cmpList cmp_ctxt a b
+ where
+ cmp_ctxt (c1, tv1) (c2, tv2)
+ = case cmp c1 c2 of { EQ_ -> cmp tv1 tv2; xxx -> xxx }
+
+-------------------
+\end{code}
+
+This is used in various places:
+\begin{code}
+pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
+
+pprContext sty [] = ppNil
+pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"]
+pprContext sty context
+ = ppBesides [ppLparen,
+ ppInterleave ppComma (map pp_assert context),
+ ppRparen, ppStr " =>"]
+ where
+ pp_assert (clas, ty)
+ = ppCat [ppr sty clas, ppr sty ty]
+\end{code}
+
+\begin{code}
+instance (Outputable name) => Outputable (PolyType name) where
+ ppr sty (HsPreForAllTy ctxt ty)
+ = print_it sty ppNil ctxt ty
+ ppr sty (HsForAllTy tvs ctxt ty)
+ = print_it sty
+ (ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "])
+ ctxt ty
+
+print_it sty pp_forall ctxt ty
+ = ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser
+ pprContext sty ctxt, ppr sty ty]
+
+instance (Outputable name) => Outputable (MonoType name) where
+ ppr = pprMonoType
+
+pREC_TOP = (0 :: Int)
+pREC_FUN = (1 :: Int)
+pREC_CON = (2 :: Int)
+
+-- printing works more-or-less as for Types
+
+pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty
+
+pprMonoType sty ty = ppr_mono_ty sty pREC_TOP ty
+pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty
+
+ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
+
+ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2)
+ = let p1 = ppr_mono_ty sty pREC_FUN ty1
+ p2 = ppr_mono_ty sty pREC_TOP ty2
+ in
+ if ctxt_prec < pREC_FUN then -- no parens needed
+ ppSep [p1, ppBeside (ppStr "-> ") p2]
+ else
+ ppSep [ppBeside ppLparen p1, ppBesides [ppStr "-> ", p2, ppRparen]]
+
+ppr_mono_ty sty ctxt_prec (MonoTupleTy tys)
+ = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen]
+
+ppr_mono_ty sty ctxt_prec (MonoListTy ty)
+ = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
+
+ppr_mono_ty sty ctxt_prec (MonoTyApp tycon tys)
+ = let pp_tycon = ppr sty tycon in
+ if null tys then
+ pp_tycon
+ else if ctxt_prec < pREC_CON then -- no parens needed
+ ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)]
+ else
+ ppBesides [ ppLparen, pp_tycon, ppSP,
+ ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys), ppRparen ]
+
+-- unfoldings only
+ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
+ = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_mono_ty sty ctxt_prec ty, ppStr "}}"]
+
+#endif {- COMPILING_GHC -}
+\end{code}
+
+Get the type variable names from a @MonoType@. Don't use class @Eq@
+because @ProtoNames@ aren't in it.
+
+\begin{code}
+#ifdef COMPILING_GHC
+
+extractCtxtTyNames :: (name -> name -> Bool) -> Context name -> [name]
+extractMonoTyNames :: (name -> name -> Bool) -> MonoType name -> [name]
+
+extractCtxtTyNames eq ctxt
+ = foldr get [] ctxt
+ where
+ get (clas, tv) acc
+ | is_elem eq tv acc = acc
+ | otherwise = tv : acc
+
+extractMonoTyNames eq ty
+ = get ty []
+ where
+ get (MonoTyApp con tys) acc = foldr get acc tys
+ get (MonoListTy ty) acc = get ty acc
+ get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
+ get (MonoDictTy _ ty) acc = get ty acc
+ get (MonoTupleTy tys) acc = foldr get acc tys
+ get (MonoTyVar name) acc
+ | is_elem eq name acc = acc
+ | otherwise = name : acc
+
+is_elem eq n [] = False
+is_elem eq n (x:xs) = n `eq` x || is_elem eq n xs
+
+#endif {- COMPILING_GHC -}
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CmdLineOpts where
-import MainMonad(MainIO(..))
-import Maybes(Labda)
-type CmdLineInfo = (GlobalSwitch -> SwitchResult, [CoreToDo], [StgToDo])
-data CoreToDo = CoreDoSimplify (SimplifierSwitch -> SwitchResult) | Core_Unused_Flag_1 | CoreDoCalcInlinings1 | CoreDoCalcInlinings2 | CoreDoFloatInwards | CoreDoFullLaziness | CoreLiberateCase | CoreDoPrintCore | CoreDoStaticArgs | CoreDoStrictness | CoreDoSpecialising | CoreDoDeforest | CoreDoAutoCostCentres | CoreDoFoldrBuildWorkerWrapper | CoreDoFoldrBuildWWAnal
-data GlobalSwitch
- = ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitDefaultInstanceMethods | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | NumbersStrict | AllDemanded | ReturnInRegsThreshold Int | VectoredReturnThreshold Int | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_show_passes | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats | D_source_stats
-type MainIO a = _State _RealWorld -> (a, _State _RealWorld)
-data Labda a
-data SimplifierSwitch = SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings | SimplNoLetFromCase | SimplNoLetFromApp | SimplNoLetFromStrictLet | SimplDontFoldBackAppend
-data StgToDo = StgDoStaticArgs | StgDoUpdateAnalysis | StgDoLambdaLift | StgDoMassageForProfiling | D_stg_stats
-data SwitchResult = SwBool Bool | SwString [Char] | SwInt Int
-classifyOpts :: [[Char]] -> _State _RealWorld -> ((GlobalSwitch -> SwitchResult, [CoreToDo], [StgToDo]), _State _RealWorld)
-intSwitchSet :: (a -> SwitchResult) -> (Int -> a) -> Labda Int
-stringSwitchSet :: (a -> SwitchResult) -> ([Char] -> a) -> Labda [Char]
-switchIsOn :: (a -> SwitchResult) -> a -> Bool
-instance Eq GlobalSwitch
-instance Eq SimplifierSwitch
-instance Ord GlobalSwitch
-instance Ord SimplifierSwitch
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The AQUA Project, Glasgow University, 1996
%
\section[CmdLineOpts]{Things to do with command-line options}
\begin{code}
#include "HsVersions.h"
-module CmdLineOpts (
- CmdLineInfo(..), SwitchResult(..),
- GlobalSwitch(..), SimplifierSwitch(..),
- CoreToDo(..),
- StgToDo(..),
-#ifdef DPH
- PodizeToDo(..),
-#endif {- Data Parallel Haskell -}
-
- classifyOpts,
- switchIsOn, stringSwitchSet, intSwitchSet,
-
- -- to make the interface self-sufficient
- Maybe, MainIO(..)
- ) where
-
-import MainMonad
-import Maybes ( maybeToBool, Maybe(..) )
-import Outputable
-import Util
-#ifdef __GLASGOW_HASKELL__
-import PreludeGlaST -- bad bad bad boy, Will
-#endif
+module CmdLineOpts where
+
+import PreludeGlaST -- bad bad bad boy, Will (_Array internals)
+import Argv
+
+CHK_Ubiq() -- debugging consistency check
+
+import Maybes ( assocMaybe, firstJust, maybeToBool, Maybe(..) )
+import Util ( panic, panic#, assertPanic )
\end{code}
A command-line {\em switch} is (generally) either on or off; e.g., the
(\tr{simplCore/SimplCore.lhs), and in the STG-to-STG processing loop
(\tr{simplStg/SimplStg.lhs}).
-We use function @classifyOpts@ to take raw command-line arguments from
-@GetArgs@ and get back the @CmdLineInfo@, which is what we really
-want.
-
%************************************************************************
%* *
-\subsection[CmdLineOpts-datatype]{Datatypes associated with command-line options}
+\subsection{Datatypes associated with command-line options}
%* *
%************************************************************************
\begin{code}
-type CmdLineInfo
- = (GlobalSwitch -> SwitchResult, -- Switch lookup function
- [CoreToDo], -- Core-to-core spec
-#ifdef DPH
- [PodizeToDo], -- Podizer spec
- [CoreToDo], -- post podized Core-to-core spec
-#endif
- [StgToDo] -- Stg-to-stg spec
- )
-
data SwitchResult
- = SwBool Bool -- on/off
- | SwString String -- nothing or a String
- | SwInt Int -- nothing or an Int
+ = SwBool Bool -- on/off
+ | SwString FAST_STRING -- nothing or a String
+ | SwInt Int -- nothing or an Int
\end{code}
\begin{code}
(SimplifierSwitch -> SwitchResult)
-- Each run of the simplifier can take a different
-- set of simplifier-specific flags.
-
- | Core_Unused_Flag_1
| CoreDoCalcInlinings1
| CoreDoCalcInlinings2
| CoreDoFloatInwards
| CoreDoAutoCostCentres
| CoreDoFoldrBuildWorkerWrapper
| CoreDoFoldrBuildWWAnal
--- ANDY:
---| CoreDoHaskPrint
---| CoreDoHaskLetlessPrint
\end{code}
\begin{code}
\end{code}
\begin{code}
-#ifdef DPH
-data PodizeToDo
- = PodizeNeeded Int -- Which dimensioned PODs need vectorizing
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-@GlobalSwitches@ may be visible everywhere in the compiler.
-@SimplifierSwitches@ (which follow) are visible only in the main
-Core-to-Core simplifier.
-
-\begin{code}
-data GlobalSwitch
- = ProduceC String -- generate C output into this file
- | ProduceS String -- generate native-code assembler into this file
- | ProduceHi String -- generate .hi interface into this file
-
- | AsmTarget String -- architecture we are generating code for
- | ForConcurrent
-
- | Haskell_1_3 -- if set => Haskell 1.3; else 1.2
- | GlasgowExts -- Glasgow Haskell extensions allowed
- | CompilingPrelude -- Compiling prelude source
-
- | HideBuiltinNames -- fiddle builtin namespace; used for compiling Prelude
- | HideMostBuiltinNames
- | EnsureSplittableC String -- (by globalising all top-level Ids w/ this String)
-
- | Verbose
- | PprStyle_User -- printing "level" (mostly for debugging)
- | PprStyle_Debug
- | PprStyle_All
-
- | DoCoreLinting -- paranoia flags
- | EmitArityChecks
-
- | OmitInterfacePragmas
- | OmitDerivedRead
- | OmitReexportedInstances
-
- | UnfoldingUseThreshold Int -- global one; see also SimplUnf...
- | UnfoldingCreationThreshold Int -- ditto
- | UnfoldingOverrideThreshold Int
-
- | ReportWhyUnfoldingsDisallowed
- | UseGetMentionedVars
- | ShowPragmaNameErrs
- | NameShadowingNotOK
- | SigsRequired
-
- | SccProfilingOn
- | AutoSccsOnExportedToplevs
- | AutoSccsOnAllToplevs
- | AutoSccsOnIndividualCafs
- | SccGroup String -- name of "group" for this cost centres in this module
-
- | DoTickyProfiling
-
- | DoSemiTagging
-
- -- ToDo: turn these into SimplifierSwitches?
- | FoldrBuildOn -- If foldr/build-style transformations are on.
- -- See also SimplDoFoldrBuild, which is used
- -- inside the simplifier.
- | FoldrBuildTrace -- show all foldr/build optimisations.
-
- | SpecialiseImports -- Treat non-essential spec requests as errors
- | ShowImportSpecs -- Output spec requests for non-essential specs
- | OmitDefaultInstanceMethods
- | SpecialiseOverloaded
- | SpecialiseUnboxed
- | SpecialiseAll
- | SpecialiseTrace
-
- -- this batch of flags is for particular experiments;
- -- v unlikely to be used in any other circumstance
- | OmitBlackHoling
- | StgDoLetNoEscapes
- | IgnoreStrictnessPragmas -- ToDo: still useful?
- | IrrefutableTuples -- We inject extra "LazyPat"s in the typechecker
- | IrrefutableEverything -- (TcPat); doing it any earlier would mean that
- -- deriving-generated code wouldn't be irrefutablified.
- | AllStrict
- | NumbersStrict
- | AllDemanded
-
- | ReturnInRegsThreshold Int
- | VectoredReturnThreshold Int -- very likely UNUSED
-
- | D_dump_rif2hs -- debugging: print out various things
- | D_dump_rn4
- | D_dump_tc
- | D_dump_deriv
- | D_dump_ds
- | D_dump_occur_anal
- | D_dump_simpl
- | D_dump_spec
- | D_dump_stranal
- | D_dump_deforest
- | D_dump_stg
- | D_dump_absC
- | D_dump_flatC
- | D_dump_realC
- | D_dump_asm
- | D_show_passes
---ANDY: | D_dump_core_passes_info -- A Gill-ism
-
- | D_verbose_core2core
- | D_verbose_stg2stg
- | D_simplifier_stats
- | D_source_stats
-
-#ifdef DPH
- | PodizeIntelligent
- | PodizeAggresive
- | PodizeVeryAggresive
- | PodizeExtremelyAggresive
- | D_dump_pod
- | D_dump_psimpl
- | D_dump_nextC
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
data SimplifierSwitch
= SimplOkToDupCode
| SimplFloatLetsExposingWHNF
| SimplDoFoldrBuild -- This is the per-simplification flag;
-- see also FoldrBuildOn, used elsewhere
-- in the compiler.
- | SimplDoNewOccurAnal -- use the *new*, all singing, Occurance analysis
| SimplDoInlineFoldrBuild
-- inline foldr/build (*after* f/b rule is used)
| SimplDontFoldBackAppend
-- we fold `foldr (:)' back into flip (++),
-- but we *don't* want to do it when compiling
- -- List.hs, otherwise
+ -- List.hs, otherwise
-- xs ++ ys = foldr (:) ys xs
-- {- via our loopback -}
-- xs ++ ys = xs ++ ys
-- Oops!
-- So only use this flag inside List.hs
-- (Sigh, what a HACK, Andy. WDP 96/01)
-{-
- | Extra__SimplFlag1
- | Extra__SimplFlag2
- | Extra__SimplFlag3
- | Extra__SimplFlag4
- | Extra__SimplFlag5
- | Extra__SimplFlag6
- | Extra__SimplFlag7
- | Extra__SimplFlag8
--}
\end{code}
%************************************************************************
%* *
-\subsection[CmdLineOpts-classify]{Classifying command-line options}
+\subsection{Classifying command-line options}
%* *
%************************************************************************
\begin{code}
-classifyOpts :: [String] -- cmd-line args, straight from GetArgs
- -> MainIO CmdLineInfo
--- The MainIO bit is because we might find an unknown flag
--- in which case we print an error message
-
-#ifndef DPH
-classifyOpts opts
- = sep opts [] [] [] -- accumulators...
- where
- sep :: [String] -- cmd-line opts (input)
- -> [GlobalSwitch] -- switch accumulator
- -> [CoreToDo] -> [StgToDo] -- to_do accumulators
- -> MainIO CmdLineInfo -- result
-
- sep [] glob_sw core_td stg_td
- = returnMn (
- isAmong glob_sw,
- reverse core_td,
- reverse stg_td
- )
-
- sep (opt1:opts) glob_sw core_td stg_td
-
-#else {- Data Parallel Haskell -}
-classifyOpts opts
- = sep opts [] [] [] [] [] -- accumulators...
+lookup :: FAST_STRING -> Bool
+lookup_int :: FAST_STRING -> Maybe Int
+lookup_str :: FAST_STRING -> Maybe FAST_STRING
+
+lookup sw = maybeToBool (assoc_opts sw)
+
+lookup_str sw = let
+ unpk_sw = _UNPK_ sw
+ in
+ case (firstJust (map (starts_with unpk_sw) unpacked_opts)) of
+ Nothing -> Nothing
+ Just xx -> Just (_PK_ xx)
+
+lookup_int sw = case (lookup_str sw) of
+ Nothing -> Nothing
+ Just xx -> Just (read (_UNPK_ xx))
+
+assoc_opts = assocMaybe [ (a, True) | a <- argv ]
+unpacked_opts = map _UNPK_ argv
+
+starts_with :: String -> String -> Maybe String
+
+starts_with [] str = Just str
+starts_with (c:cs) (s:ss)
+ = if c /= s then Nothing else starts_with cs ss
+\end{code}
+
+\begin{code}
+opt_AllDemanded = lookup SLIT("-fall-demanded")
+opt_AllStrict = lookup SLIT("-fall-strict")
+opt_AutoSccsOnAllToplevs = lookup SLIT("-fauto-sccs-on-all-toplevs")
+opt_AutoSccsOnExportedToplevs = lookup SLIT("-fauto-sccs-on-exported-toplevs")
+opt_AutoSccsOnIndividualCafs = lookup SLIT("-fauto-sccs-on-individual-cafs")
+opt_CompilingPrelude = lookup SLIT("-prelude")
+opt_D_dump_absC = lookup SLIT("-ddump-absC")
+opt_D_dump_asm = lookup SLIT("-ddump-asm")
+opt_D_dump_deforest = lookup SLIT("-ddump-deforest")
+opt_D_dump_deriv = lookup SLIT("-ddump-deriv")
+opt_D_dump_ds = lookup SLIT("-ddump-ds")
+opt_D_dump_flatC = lookup SLIT("-ddump-flatC")
+opt_D_dump_occur_anal = lookup SLIT("-ddump-occur-anal")
+opt_D_dump_rdr = lookup SLIT("-ddump-rdr")
+opt_D_dump_realC = lookup SLIT("-ddump-realC")
+opt_D_dump_rn = lookup SLIT("-ddump-rn")
+opt_D_dump_simpl = lookup SLIT("-ddump-simpl")
+opt_D_dump_spec = lookup SLIT("-ddump-spec")
+opt_D_dump_stg = lookup SLIT("-ddump-stg")
+opt_D_dump_stranal = lookup SLIT("-ddump-stranal")
+opt_D_dump_tc = lookup SLIT("-ddump-tc")
+opt_D_show_passes = lookup SLIT("-dshow-passes")
+opt_D_simplifier_stats = lookup SLIT("-dsimplifier-stats")
+opt_D_source_stats = lookup SLIT("-dsource-stats")
+opt_D_verbose_core2core = lookup SLIT("-dverbose-simpl")
+opt_D_verbose_stg2stg = lookup SLIT("-dverbose-stg")
+opt_DoCoreLinting = lookup SLIT("-dcore-lint")
+opt_DoSemiTagging = lookup SLIT("-fsemi-tagging")
+opt_DoTickyProfiling = lookup SLIT("-fticky-ticky")
+opt_EmitArityChecks = lookup SLIT("-darity-checks")
+opt_FoldrBuildOn = lookup SLIT("-ffoldr-build-on")
+opt_FoldrBuildTrace = lookup SLIT("-ffoldr-build-trace")
+opt_ForConcurrent = lookup SLIT("-fconcurrent")
+opt_GlasgowExts = lookup SLIT("-fglasgow-exts")
+opt_Haskell_1_3 = lookup SLIT("-fhaskell-1.3")
+opt_HideBuiltinNames = lookup SLIT("-fhide-builtin-names")
+opt_HideMostBuiltinNames = lookup SLIT("-fmin-builtin-names")
+opt_IgnoreStrictnessPragmas = lookup SLIT("-fignore-strictness-pragmas")
+opt_IrrefutableEverything = lookup SLIT("-firrefutable-everything")
+opt_IrrefutableTuples = lookup SLIT("-firrefutable-tuples")
+opt_NameShadowingNotOK = lookup SLIT("-fname-shadowing-not-ok")
+opt_NumbersStrict = lookup SLIT("-fnumbers-strict")
+opt_OmitBlackHoling = lookup SLIT("-dno-black-holing")
+opt_OmitDefaultInstanceMethods = lookup SLIT("-fomit-default-instance-methods")
+opt_OmitInterfacePragmas = lookup SLIT("-fomit-interface-pragmas")
+opt_OmitReexportedInstances = lookup SLIT("-fomit-reexported-instances")
+opt_PprStyle_All = lookup SLIT("-dppr-all")
+opt_PprStyle_Debug = lookup SLIT("-dppr-debug")
+opt_PprStyle_User = lookup SLIT("-dppr-user")
+opt_ReportWhyUnfoldingsDisallowed= lookup SLIT("-freport-disallowed-unfoldings")
+opt_SccProfilingOn = lookup SLIT("-fscc-profiling")
+opt_ShowImportSpecs = lookup SLIT("-fshow-import-specs")
+opt_ShowPragmaNameErrs = lookup SLIT("-fshow-pragma-name-errs")
+opt_SigsRequired = lookup SLIT("-fsignatures-required")
+opt_SpecialiseAll = lookup SLIT("-fspecialise-all")
+opt_SpecialiseImports = lookup SLIT("-fspecialise-imports")
+opt_SpecialiseOverloaded = lookup SLIT("-fspecialise-overloaded")
+opt_SpecialiseTrace = lookup SLIT("-ftrace-specialisation")
+opt_SpecialiseUnboxed = lookup SLIT("-fspecialise-unboxed")
+opt_StgDoLetNoEscapes = lookup SLIT("-flet-no-escape")
+opt_UseGetMentionedVars = lookup SLIT("-fuse-get-mentioned-vars")
+opt_Verbose = lookup SLIT("-v")
+opt_AsmTarget = lookup_str SLIT("-fasm-")
+opt_SccGroup = lookup_str SLIT("-G")
+opt_ProduceC = lookup_str SLIT("-C")
+opt_ProduceS = lookup_str SLIT("-S")
+opt_ProduceHi = lookup_str SLIT("-hi")
+opt_EnsureSplittableC = lookup_str SLIT("-fglobalise-toplev-names")
+opt_UnfoldingUseThreshold = lookup_int SLIT("-funfolding-use-threshold")
+opt_UnfoldingCreationThreshold = lookup_int SLIT("-funfolding-creation-threshold")
+opt_UnfoldingOverrideThreshold = lookup_int SLIT("-funfolding-override-threshold")
+opt_ReturnInRegsThreshold = lookup_int SLIT("-freturn-in-regs-threshold")
+\end{code}
+
+\begin{code}
+classifyOpts :: ([CoreToDo], -- Core-to-Core processing spec
+ [StgToDo]) -- STG-to-STG processing spec
+
+classifyOpts = sep argv [] [] -- accumulators...
where
- sep :: [String] -- cmd-line opts (input)
- -> [GlobalSwitch] -- switch accumulator
- -> [CoreToDo] -> [PodizeToDo] -- to_do accumulators
- -> [CoreToDo] -> [StgToDo]
- -> MainIO CmdLineInfo -- result
-
- -- see also the related "simpl_sep" function, used
- -- to collect up the SimplifierSwitches for a "-fsimplify".
-
- sep [] glob_sw core_td pod_td pcore_td stg_td
- = returnMn (
- isAmong glob_sw,
- reverse core_td,
- reverse pod_td,
- reverse pcore_td,
- reverse stg_td
- )
-
- sep (opt1:opts) glob_sw core_td pod_td pcore_td stg_td
-#endif {- Data Parallel Haskell -}
-
-#ifndef DPH
-#define GLOBAL_SW(switch) sep opts (switch:glob_sw) core_td stg_td
-#define CORE_TD(to_do) sep opts glob_sw (to_do:core_td) stg_td
-#define POD_TD(to_do) sep opts glob_sw core_td stg_td
-#define PAR_CORE_TD(to_do) sep opts glob_sw core_td stg_td
-#define BOTH_CORE_TD(to_do) sep opts glob_sw (to_do:core_td) stg_td
-#define STG_TD(to_do) sep opts glob_sw core_td (to_do:stg_td)
-#define IGNORE_ARG() sep opts glob_sw core_td stg_td
-
-#else
-
-#define GLOBAL_SW(switch) sep opts (switch:glob_sw) core_td pod_td pcore_td stg_td
-#define CORE_TD(to_do) sep opts glob_sw (to_do:core_td) pod_td pcore_td stg_td
-#define POD_TD(to_do) sep opts glob_sw core_td (to_do:pod_td) pcore_td stg_td
-#define PAR_CORE_TD(do) sep opts glob_sw core_td pod_td (do:pcore_td) stg_td
-#define BOTH_CORE_TD(do) sep opts glob_sw (do:core_td) pod_td (do:pcore_td) stg_td
-#define STG_TD(to_do) sep opts glob_sw core_td pod_td pcore_td (to_do:stg_td)
-#define IGNORE_ARG() sep opts glob_sw core_td pod_td pcore_td stg_td
-
-#endif {- Data Parallel Haskell -}
-
--- ToDo: DPH-ify
-#define GLOBAL_SIMPL_SW(switch) simpl_sep opts (switch:simpl_sw) glob_sw core_td stg_td
-
- = let
- maybe_fasm = starts_with "-fasm-" opt1
- maybe_G = starts_with "-G" opt1
- maybe_C = starts_with "-C" opt1
- maybe_S = starts_with "-S" opt1
- maybe_hi = starts_with "-hi" opt1
- maybe_hu = starts_with "-hu" opt1
- maybe_uut = starts_with "-funfolding-use-threshold" opt1
- maybe_uct = starts_with "-funfolding-creation-threshold" opt1
- maybe_uot = starts_with "-funfolding-override-threshold" opt1
- maybe_rirt = starts_with "-freturn-in-regs-threshold" opt1
- maybe_gtn = starts_with "-fglobalise-toplev-names" opt1
- starts_with_fasm = maybeToBool maybe_fasm
- starts_with_G = maybeToBool maybe_G
- starts_with_C = maybeToBool maybe_C
- starts_with_S = maybeToBool maybe_S
- starts_with_hi = maybeToBool maybe_hi
- starts_with_hu = maybeToBool maybe_hu
- starts_with_uut = maybeToBool maybe_uut
- starts_with_uct = maybeToBool maybe_uct
- starts_with_uot = maybeToBool maybe_uot
- starts_with_rirt = maybeToBool maybe_rirt
- starts_with_gtn = maybeToBool maybe_gtn
- (Just after_fasm) = maybe_fasm
- (Just after_G) = maybe_G
- (Just after_C) = maybe_C
- (Just after_S) = maybe_S
- (Just after_hi) = maybe_hi
- (Just after_hu) = maybe_hu
- (Just after_uut) = maybe_uut
- (Just after_uct) = maybe_uct
- (Just after_uot) = maybe_uot
- (Just after_rirt) = maybe_rirt
- (Just after_gtn) = maybe_gtn
- in
- case opt1 of -- the non-"just match a string" options are at the end...
- ',' : _ -> IGNORE_ARG() -- it is for the parser
- "-ddump-rif2hs" -> GLOBAL_SW(D_dump_rif2hs)
- "-ddump-rn4" -> GLOBAL_SW(D_dump_rn4)
- "-ddump-tc" -> GLOBAL_SW(D_dump_tc)
- "-ddump-deriv" -> GLOBAL_SW(D_dump_deriv)
- "-ddump-ds" -> GLOBAL_SW(D_dump_ds)
- "-ddump-stranal" -> GLOBAL_SW(D_dump_stranal)
- "-ddump-deforest"-> GLOBAL_SW(D_dump_deforest)
- "-ddump-spec" -> GLOBAL_SW(D_dump_spec)
- "-ddump-simpl" -> GLOBAL_SW(D_dump_simpl)
- "-ddump-occur-anal" -> GLOBAL_SW(D_dump_occur_anal)
-#ifdef DPH
- "-ddump-pod" -> GLOBAL_SW(D_dump_pod)
- "-ddump-psimpl" -> GLOBAL_SW(D_dump_psimpl)
- "-ddump-nextC" -> GLOBAL_SW(D_dump_nextC)
-#endif {- Data Parallel Haskell -}
-
- "-ddump-stg" -> GLOBAL_SW(D_dump_stg)
- "-ddump-absC" -> GLOBAL_SW(D_dump_absC)
- "-ddump-flatC" -> GLOBAL_SW(D_dump_flatC)
- "-ddump-realC" -> GLOBAL_SW(D_dump_realC)
- "-ddump-asm" -> GLOBAL_SW(D_dump_asm)
- "-dshow-passes" -> GLOBAL_SW(D_show_passes)
-
--- ANDY: "-ddump-haskell" -> GLOBAL_SW(D_dump_core_passes_info)
- "-dsimplifier-stats" -> GLOBAL_SW(D_simplifier_stats)
- "-dsource-stats" -> GLOBAL_SW(D_source_stats)
-
- "-dverbose-simpl" ->GLOBAL_SW(D_verbose_core2core)
- "-dverbose-stg" -> GLOBAL_SW(D_verbose_stg2stg)
-
- "-fuse-get-mentioned-vars" -> GLOBAL_SW(UseGetMentionedVars)
-
- "-fhaskell-1.3" -> GLOBAL_SW(Haskell_1_3)
- "-dcore-lint" -> GLOBAL_SW(DoCoreLinting)
- "-fomit-interface-pragmas" -> GLOBAL_SW(OmitInterfacePragmas)
- "-fignore-strictness-pragmas" -> GLOBAL_SW(IgnoreStrictnessPragmas)
- "-firrefutable-tuples" -> GLOBAL_SW(IrrefutableTuples)
- "-firrefutable-everything" -> GLOBAL_SW(IrrefutableEverything)
- "-fall-strict" -> GLOBAL_SW(AllStrict)
- "-fnumbers-strict" -> GLOBAL_SW(NumbersStrict)
- "-fall-demanded" -> GLOBAL_SW(AllDemanded)
-
- "-fsemi-tagging" -> GLOBAL_SW(DoSemiTagging)
-
- "-fsimplify" -> -- gather up SimplifierSwitches specially...
- simpl_sep opts [] glob_sw core_td stg_td
+ sep :: [FAST_STRING] -- cmd-line opts (input)
+ -> [CoreToDo] -> [StgToDo] -- to_do accumulators
+ -> ([CoreToDo], [StgToDo]) -- result
+
+ sep [] core_td stg_td -- all done!
+ = (reverse core_td, reverse stg_td)
+
+# define CORE_TD(to_do) sep opts (to_do:core_td) stg_td
+# define STG_TD(to_do) sep opts core_td (to_do:stg_td)
+# define IGNORE_ARG() sep opts core_td stg_td
+
+ sep (opt1:opts) core_td stg_td
+ =
+ case (_UNPK_ opt1) of -- the non-"just match a string" options are at the end...
+
+ ',' : _ -> IGNORE_ARG() -- it is for the parser
+
+ "-fsimplify" -> -- gather up SimplifierSwitches specially...
+ simpl_sep opts [] core_td stg_td
"-fcalc-inlinings1"-> CORE_TD(CoreDoCalcInlinings1)
"-fcalc-inlinings2"-> CORE_TD(CoreDoCalcInlinings2)
"-ffloat-inwards" -> CORE_TD(CoreDoFloatInwards)
"-ffull-laziness" -> CORE_TD(CoreDoFullLaziness)
- "-fliberate-case" -> CORE_TD(CoreLiberateCase)
- "-fprint-core" -> CORE_TD(CoreDoPrintCore)
+ "-fliberate-case" -> CORE_TD(CoreLiberateCase)
+ "-fprint-core" -> CORE_TD(CoreDoPrintCore)
"-fstatic-args" -> CORE_TD(CoreDoStaticArgs)
"-fstrictness" -> CORE_TD(CoreDoStrictness)
"-fspecialise" -> CORE_TD(CoreDoSpecialising)
"-fadd-auto-sccs" -> CORE_TD(CoreDoAutoCostCentres)
"-ffoldr-build-worker-wrapper" -> CORE_TD(CoreDoFoldrBuildWorkerWrapper)
"-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal)
---ANDY: "-fprint-haskell-core" -> CORE_TD(CoreDoHaskPrint)
--- "-fprint-haskell-letless-core" -> CORE_TD(CoreDoHaskLetlessPrint)
- "-fomit-default-instance-methods" -> GLOBAL_SW(OmitDefaultInstanceMethods)
- "-fspecialise-overloaded" -> GLOBAL_SW(SpecialiseOverloaded)
- "-fspecialise-unboxed" -> GLOBAL_SW(SpecialiseUnboxed)
- "-fspecialise-all" -> GLOBAL_SW(SpecialiseAll)
- "-fspecialise-imports" -> GLOBAL_SW(SpecialiseImports)
- "-fshow-import-specs" -> GLOBAL_SW(ShowImportSpecs)
- "-ftrace-specialisation" -> GLOBAL_SW(SpecialiseTrace)
-
- "-freport-disallowed-unfoldings"
- -> GLOBAL_SW(ReportWhyUnfoldingsDisallowed)
-
- "-fomit-derived-read" -> GLOBAL_SW(OmitDerivedRead)
-
- "-ffoldr-build-on" -> GLOBAL_SW(FoldrBuildOn)
- "-ffoldr-build-trace" -> GLOBAL_SW(FoldrBuildTrace)
"-fstg-static-args" -> STG_TD(StgDoStaticArgs)
"-fupdate-analysis" -> STG_TD(StgDoUpdateAnalysis)
"-flambda-lift" -> STG_TD(StgDoLambdaLift)
"-fmassage-stg-for-profiling" -> STG_TD(StgDoMassageForProfiling)
- "-flet-no-escape" -> GLOBAL_SW(StgDoLetNoEscapes)
-
-#ifdef DPH
- "-fpodize-vector" -> POD_TD(PodizeNeeded 1)
- "-fpodize-matrix" -> POD_TD(PodizeNeeded 2)
- "-fpodize-cube" -> POD_TD(PodizeNeeded 3)
- "-fpodize-intelligent" -> GLOBAL_SW(PodizeIntelligent)
- "-fpodize-aggresive" -> GLOBAL_SW(PodizeAggresive)
- "-fpodize-very-aggresive" -> GLOBAL_SW(PodizeVeryAggresive)
- "-fpodize-extremely-aggresive" -> GLOBAL_SW(PodizeExtremelyAggresive)
-#endif {- Data Parallel Haskell -}
-
- "-v" -> GLOBAL_SW(Verbose)
-
- "-fglasgow-exts" -> GLOBAL_SW(GlasgowExts)
- "-prelude" -> GLOBAL_SW(CompilingPrelude)
-
- "-fscc-profiling" -> GLOBAL_SW(SccProfilingOn)
- "-fauto-sccs-on-exported-toplevs" -> GLOBAL_SW(AutoSccsOnExportedToplevs)
- "-fauto-sccs-on-all-toplevs" -> GLOBAL_SW(AutoSccsOnAllToplevs)
- "-fauto-sccs-on-individual-cafs" -> GLOBAL_SW(AutoSccsOnIndividualCafs)
-
- "-fticky-ticky" -> GLOBAL_SW(DoTickyProfiling)
-
- "-dppr-user" -> GLOBAL_SW(PprStyle_User)
- "-dppr-debug" -> GLOBAL_SW(PprStyle_Debug)
- "-dppr-all" -> GLOBAL_SW(PprStyle_All)
-
- "-fhide-builtin-names"-> GLOBAL_SW(HideBuiltinNames)
- "-fmin-builtin-names" -> GLOBAL_SW(HideMostBuiltinNames)
-
- "-fconcurrent" -> GLOBAL_SW(ForConcurrent)
-
- "-fshow-pragma-name-errs" -> GLOBAL_SW(ShowPragmaNameErrs)
- "-fname-shadowing-not-ok" -> GLOBAL_SW(NameShadowingNotOK)
- "-fsignatures-required" -> GLOBAL_SW(SigsRequired)
- "-fomit-reexported-instances" -> GLOBAL_SW(OmitReexportedInstances)
- "-darity-checks" -> GLOBAL_SW(EmitArityChecks)
- "-dno-black-holing"-> GLOBAL_SW(OmitBlackHoling)
-
- _ | starts_with_fasm -> GLOBAL_SW(AsmTarget after_fasm)
- | starts_with_G -> GLOBAL_SW(SccGroup after_G) -- profiling "group"
- | starts_with_C -> GLOBAL_SW(ProduceC after_C) -- main C output
- | starts_with_S -> GLOBAL_SW(ProduceS after_S) -- main .s output
- | starts_with_hi -> GLOBAL_SW(ProduceHi after_hi) -- interface
---UNUSED: | starts_with_hu -> GLOBAL_SW(ProduceHu after_hu) -- usage info
-
- | starts_with_uut -> GLOBAL_SW(UnfoldingUseThreshold (read after_uut))
- | starts_with_uct -> GLOBAL_SW(UnfoldingCreationThreshold (read after_uct))
- | starts_with_uot -> GLOBAL_SW(UnfoldingOverrideThreshold (read after_uot))
-
- | starts_with_rirt -> -- trace ("rirt:"++after_rirt) $
- GLOBAL_SW(ReturnInRegsThreshold (read after_rirt))
-
- | starts_with_gtn -> GLOBAL_SW(EnsureSplittableC after_gtn)
-
-
- _ -> writeMn stderr ("*** WARNING: bad option: "++opt1++"\n") `thenMn` ( \ _ ->
- -- NB: the driver is really supposed to handle bad options
- IGNORE_ARG() )
+ _ -> -- NB: the driver is really supposed to handle bad options
+ IGNORE_ARG()
----------------
- starts_with :: String -> String -> Maybe String
-
- starts_with [] str = Just str
- starts_with (c:cs) (s:ss)
- = if c /= s then Nothing else starts_with cs ss
-
- ----------------
-
- -- ToDo: DPH-ify "simpl_sep"!
-
- simpl_sep :: [String] -- cmd-line opts (input)
- -> [SimplifierSwitch] -- simplifier-switch accumulator
- -> [GlobalSwitch] -- switch accumulator
- -> [CoreToDo] -> [StgToDo] -- to_do accumulators
- -> MainIO CmdLineInfo -- result
+ simpl_sep :: [FAST_STRING] -- cmd-line opts (input)
+ -> [SimplifierSwitch] -- simplifier-switch accumulator
+ -> [CoreToDo] -> [StgToDo] -- to_do accumulators
+ -> ([CoreToDo], [StgToDo]) -- result
-- "simpl_sep" tailcalls "sep" once it's seen one set
-- of SimplifierSwitches for a CoreDoSimplify.
#ifdef DEBUG
- simpl_sep input@[] simpl_sw glob_sw core_td stg_td
+ simpl_sep input@[] simpl_sw core_td stg_td
= panic "simpl_sep []"
#endif
-- The SimplifierSwitches should be delimited by "(" and ")".
- simpl_sep ("(":opts) [{-better be empty-}] glob_sw core_td stg_td
- = simpl_sep opts [] glob_sw core_td stg_td
-
- simpl_sep (")":opts) simpl_sw glob_sw core_td stg_td
- = let
- this_CoreDoSimplify = CoreDoSimplify (isAmongSimpl simpl_sw)
- in
- sep opts glob_sw (this_CoreDoSimplify : core_td) stg_td
-
- simpl_sep (opt1:opts) simpl_sw glob_sw core_td stg_td
- = let
- maybe_suut = starts_with "-fsimpl-uf-use-threshold" opt1
- maybe_suct = starts_with "-fsimpl-uf-creation-threshold" opt1
- maybe_msi = starts_with "-fmax-simplifier-iterations" opt1
+ simpl_sep (opt1:opts) simpl_sw core_td stg_td
+ = case (_UNPK_ opt1) of
+ "(" -> ASSERT (null simpl_sw)
+ simpl_sep opts [] core_td stg_td
+ ")" -> let
+ this_simpl = CoreDoSimplify (isAmongSimpl simpl_sw)
+ in
+ sep opts (this_simpl : core_td) stg_td
+
+# define SIMPL_SW(sw) simpl_sep opts (sw:simpl_sw) core_td stg_td
+
+ -- the non-"just match a string" options are at the end...
+ "-fshow-simplifier-progress" -> SIMPL_SW(ShowSimplifierProgress)
+ "-fcode-duplication-ok" -> SIMPL_SW(SimplOkToDupCode)
+ "-ffloat-lets-exposing-whnf" -> SIMPL_SW(SimplFloatLetsExposingWHNF)
+ "-ffloat-primops-ok" -> SIMPL_SW(SimplOkToFloatPrimOps)
+ "-falways-float-lets-from-lets" -> SIMPL_SW(SimplAlwaysFloatLetsFromLets)
+ "-fdo-case-elim" -> SIMPL_SW(SimplDoCaseElim)
+ "-fdo-eta-reduction" -> SIMPL_SW(SimplDoEtaReduction)
+ "-fdo-lambda-eta-expansion" -> SIMPL_SW(SimplDoLambdaEtaExpansion)
+ "-fdo-foldr-build" -> SIMPL_SW(SimplDoFoldrBuild)
+ "-fdo-not-fold-back-append" -> SIMPL_SW(SimplDontFoldBackAppend)
+ "-fdo-arity-expand" -> SIMPL_SW(SimplDoArityExpand)
+ "-fdo-inline-foldr-build" -> SIMPL_SW(SimplDoInlineFoldrBuild)
+ "-freuse-con" -> SIMPL_SW(SimplReuseCon)
+ "-fcase-of-case" -> SIMPL_SW(SimplCaseOfCase)
+ "-flet-to-case" -> SIMPL_SW(SimplLetToCase)
+ "-fpedantic-bottoms" -> SIMPL_SW(SimplPedanticBottoms)
+ "-fkeep-spec-pragma-ids" -> SIMPL_SW(KeepSpecPragmaIds)
+ "-fkeep-unused-bindings" -> SIMPL_SW(KeepUnusedBindings)
+ "-fmay-delete-conjurable-ids" -> SIMPL_SW(SimplMayDeleteConjurableIds)
+ "-fessential-unfoldings-only" -> SIMPL_SW(EssentialUnfoldingsOnly)
+ "-fignore-inline-pragma" -> SIMPL_SW(IgnoreINLINEPragma)
+ "-fno-let-from-case" -> SIMPL_SW(SimplNoLetFromCase)
+ "-fno-let-from-app" -> SIMPL_SW(SimplNoLetFromApp)
+ "-fno-let-from-strict-let" -> SIMPL_SW(SimplNoLetFromStrictLet)
+
+ o | starts_with_msi -> SIMPL_SW(MaxSimplifierIterations (read after_msi))
+ | starts_with_suut -> SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut))
+ | starts_with_suct -> SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct))
+ where
+ maybe_suut = starts_with "-fsimpl-uf-use-threshold" o
+ maybe_suct = starts_with "-fsimpl-uf-creation-threshold" o
+ maybe_msi = starts_with "-fmax-simplifier-iterations" o
starts_with_suut = maybeToBool maybe_suut
starts_with_suct = maybeToBool maybe_suct
starts_with_msi = maybeToBool maybe_msi
(Just after_suut) = maybe_suut
(Just after_suct) = maybe_suct
(Just after_msi) = maybe_msi
- in
- case opt1 of -- the non-"just match a string" options are at the end...
- "-fshow-simplifier-progress" -> GLOBAL_SIMPL_SW(ShowSimplifierProgress)
-
- "-fcode-duplication-ok" -> GLOBAL_SIMPL_SW(SimplOkToDupCode)
- "-ffloat-lets-exposing-whnf" -> GLOBAL_SIMPL_SW(SimplFloatLetsExposingWHNF)
- "-ffloat-primops-ok" -> GLOBAL_SIMPL_SW(SimplOkToFloatPrimOps)
- "-falways-float-lets-from-lets" -> GLOBAL_SIMPL_SW(SimplAlwaysFloatLetsFromLets)
- "-fdo-case-elim" -> GLOBAL_SIMPL_SW(SimplDoCaseElim)
- "-fdo-eta-reduction" -> GLOBAL_SIMPL_SW(SimplDoEtaReduction)
- "-fdo-lambda-eta-expansion" -> GLOBAL_SIMPL_SW(SimplDoLambdaEtaExpansion)
- "-fdo-foldr-build" -> GLOBAL_SIMPL_SW(SimplDoFoldrBuild)
- "-fdo-not-fold-back-append" -> GLOBAL_SIMPL_SW(SimplDontFoldBackAppend)
- "-fdo-new-occur-anal" -> GLOBAL_SIMPL_SW(SimplDoNewOccurAnal)
- "-fdo-arity-expand" -> GLOBAL_SIMPL_SW(SimplDoArityExpand)
- "-fdo-inline-foldr-build" -> GLOBAL_SIMPL_SW(SimplDoInlineFoldrBuild)
- "-freuse-con" -> GLOBAL_SIMPL_SW(SimplReuseCon)
- "-fcase-of-case" -> GLOBAL_SIMPL_SW(SimplCaseOfCase)
- "-flet-to-case" -> GLOBAL_SIMPL_SW(SimplLetToCase)
- "-fpedantic-bottoms" -> GLOBAL_SIMPL_SW(SimplPedanticBottoms)
- "-fkeep-spec-pragma-ids" -> GLOBAL_SIMPL_SW(KeepSpecPragmaIds)
- "-fkeep-unused-bindings" -> GLOBAL_SIMPL_SW(KeepUnusedBindings)
- "-fmay-delete-conjurable-ids" -> GLOBAL_SIMPL_SW(SimplMayDeleteConjurableIds)
- "-fessential-unfoldings-only" -> GLOBAL_SIMPL_SW(EssentialUnfoldingsOnly)
- "-fignore-inline-pragma" -> GLOBAL_SIMPL_SW(IgnoreINLINEPragma)
- "-fno-let-from-case" -> GLOBAL_SIMPL_SW(SimplNoLetFromCase)
- "-fno-let-from-app" -> GLOBAL_SIMPL_SW(SimplNoLetFromApp)
- "-fno-let-from-strict-let" -> GLOBAL_SIMPL_SW(SimplNoLetFromStrictLet)
-
- _ | starts_with_msi -> GLOBAL_SIMPL_SW(MaxSimplifierIterations (read after_msi))
- | starts_with_suut -> GLOBAL_SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut))
- | starts_with_suct -> GLOBAL_SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct))
-
- _ -> writeMn stderr ("*** WARNING: bad simplifier option: "++opt1++"\n") `thenMn` ( \ _ ->
- -- NB: the driver is really supposed to handle bad options
- simpl_sep opts simpl_sw glob_sw core_td stg_td )
+
+ _ -> -- NB: the driver is really supposed to handle bad options
+ simpl_sep opts simpl_sw core_td stg_td
\end{code}
%************************************************************************
%* *
-\subsection[CmdLineOpts-order]{Switch ordering}
+\subsection{Switch ordering}
%* *
%************************************************************************
behave just like enumeration types.
\begin{code}
-instance Eq GlobalSwitch where
- a == b = tagOf_Switch a _EQ_ tagOf_Switch b
-
-instance Ord GlobalSwitch where
- a < b = tagOf_Switch a _LT_ tagOf_Switch b
- a <= b = tagOf_Switch a _LE_ tagOf_Switch b
-
instance Eq SimplifierSwitch where
a == b = tagOf_SimplSwitch a _EQ_ tagOf_SimplSwitch b
a < b = tagOf_SimplSwitch a _LT_ tagOf_SimplSwitch b
a <= b = tagOf_SimplSwitch a _LE_ tagOf_SimplSwitch b
-tagOf_Switch (ProduceC _) =(ILIT(0) :: FAST_INT)
-tagOf_Switch (ProduceS _) = ILIT(1)
-tagOf_Switch (ProduceHi _) = ILIT(2)
-tagOf_Switch (AsmTarget _) = ILIT(4)
-tagOf_Switch ForConcurrent = ILIT(6)
-tagOf_Switch Haskell_1_3 = ILIT(8)
-tagOf_Switch GlasgowExts = ILIT(9)
-tagOf_Switch CompilingPrelude = ILIT(10)
-tagOf_Switch HideBuiltinNames = ILIT(11)
-tagOf_Switch HideMostBuiltinNames = ILIT(12)
-tagOf_Switch (EnsureSplittableC _) = ILIT(13)
-tagOf_Switch Verbose = ILIT(14)
-tagOf_Switch PprStyle_User = ILIT(15)
-tagOf_Switch PprStyle_Debug = ILIT(16)
-tagOf_Switch PprStyle_All = ILIT(17)
-tagOf_Switch DoCoreLinting = ILIT(18)
-tagOf_Switch EmitArityChecks = ILIT(19)
-tagOf_Switch OmitInterfacePragmas = ILIT(20)
-tagOf_Switch OmitDerivedRead = ILIT(21)
-tagOf_Switch OmitReexportedInstances = ILIT(22)
-tagOf_Switch (UnfoldingUseThreshold _) = ILIT(23)
-tagOf_Switch (UnfoldingCreationThreshold _) = ILIT(24)
-tagOf_Switch (UnfoldingOverrideThreshold _) = ILIT(25)
-tagOf_Switch ReportWhyUnfoldingsDisallowed = ILIT(26)
-tagOf_Switch UseGetMentionedVars = ILIT(27)
-tagOf_Switch ShowPragmaNameErrs = ILIT(28)
-tagOf_Switch NameShadowingNotOK = ILIT(29)
-tagOf_Switch SigsRequired = ILIT(30)
-tagOf_Switch SccProfilingOn = ILIT(31)
-tagOf_Switch AutoSccsOnExportedToplevs = ILIT(32)
-tagOf_Switch AutoSccsOnAllToplevs = ILIT(33)
-tagOf_Switch AutoSccsOnIndividualCafs = ILIT(34)
-tagOf_Switch (SccGroup _) = ILIT(36)
-tagOf_Switch DoTickyProfiling = ILIT(37)
-tagOf_Switch DoSemiTagging = ILIT(38)
-tagOf_Switch FoldrBuildOn = ILIT(39)
-tagOf_Switch FoldrBuildTrace = ILIT(40)
-tagOf_Switch SpecialiseImports = ILIT(41)
-tagOf_Switch ShowImportSpecs = ILIT(42)
-tagOf_Switch OmitDefaultInstanceMethods = ILIT(43)
-tagOf_Switch SpecialiseOverloaded = ILIT(44)
-tagOf_Switch SpecialiseUnboxed = ILIT(45)
-tagOf_Switch SpecialiseAll = ILIT(46)
-tagOf_Switch SpecialiseTrace = ILIT(47)
-
-tagOf_Switch OmitBlackHoling = ILIT(49)
-tagOf_Switch StgDoLetNoEscapes = ILIT(50)
-tagOf_Switch IgnoreStrictnessPragmas = ILIT(51)
-tagOf_Switch IrrefutableTuples = ILIT(52)
-tagOf_Switch IrrefutableEverything = ILIT(53)
-tagOf_Switch AllStrict = ILIT(54)
-tagOf_Switch NumbersStrict = ILIT(55)
-tagOf_Switch AllDemanded = ILIT(56)
-
-tagOf_Switch (ReturnInRegsThreshold _) = ILIT(57)
-tagOf_Switch (VectoredReturnThreshold _)= ILIT(58)
-tagOf_Switch D_dump_rif2hs = ILIT(59)
-tagOf_Switch D_dump_rn4 = ILIT(60)
-tagOf_Switch D_dump_tc = ILIT(61)
-tagOf_Switch D_dump_deriv = ILIT(62)
-tagOf_Switch D_dump_ds = ILIT(63)
-tagOf_Switch D_dump_simpl = ILIT(64)
-tagOf_Switch D_dump_spec = ILIT(65)
-tagOf_Switch D_dump_occur_anal = ILIT(66)
-tagOf_Switch D_dump_stranal = ILIT(67)
-tagOf_Switch D_dump_stg = ILIT(68)
-tagOf_Switch D_dump_absC = ILIT(69)
-tagOf_Switch D_dump_flatC = ILIT(70)
-tagOf_Switch D_dump_realC = ILIT(71)
-tagOf_Switch D_dump_asm = ILIT(72)
-tagOf_Switch D_show_passes = ILIT(73)
---ANDY:tagOf_Switch D_dump_core_passes_info = ILIT(??)
-tagOf_Switch D_verbose_core2core = ILIT(74)
-tagOf_Switch D_verbose_stg2stg = ILIT(75)
-tagOf_Switch D_simplifier_stats = ILIT(76)
-tagOf_Switch D_source_stats = ILIT(77) {-see note below!-}
-
-#ifndef DPH
-tagOf_Switch _ = case (panic "tagOf_Switch") of -- BUG avoidance
- s -> tagOf_Switch s
-
-lAST_SWITCH_TAG = IBOX(tagOf_Switch D_source_stats)
-
-#else {- Data Parallel Haskell -}
-
-tagOf_Switch PodizeIntelligent = ILIT(90)
-tagOf_Switch PodizeAggresive = ILIT(91)
-tagOf_Switch PodizeVeryAggresive = ILIT(92)
-tagOf_Switch PodizeExtremelyAggresive = ILIT(93)
-tagOf_Switch D_dump_pod = ILIT(94)
-tagOf_Switch D_dump_psimpl = ILIT(95)
-tagOf_Switch D_dump_nextC = ILIT(96)
-
-tagOf_Switch _ = case (panic "tagOf_Switch") of -- BUG avoidance
- s -> tagOf_Switch s
-
-lAST_SWITCH_TAG = IBOX(tagOf_Switch D_dump_nextC)
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-(Note For Will): Could you please leave a little extra room between
-your last option and @D_dump_spec@... Thanks... jon...
-
-\begin{code}
tagOf_SimplSwitch SimplOkToDupCode =(ILIT(0) :: FAST_INT)
tagOf_SimplSwitch SimplFloatLetsExposingWHNF = ILIT(1)
tagOf_SimplSwitch SimplOkToFloatPrimOps = ILIT(2)
tagOf_SimplSwitch SimplPedanticBottoms = ILIT(10)
tagOf_SimplSwitch SimplDoArityExpand = ILIT(11)
tagOf_SimplSwitch SimplDoFoldrBuild = ILIT(12)
-tagOf_SimplSwitch SimplDoNewOccurAnal = ILIT(13)
tagOf_SimplSwitch SimplDoInlineFoldrBuild = ILIT(14)
tagOf_SimplSwitch IgnoreINLINEPragma = ILIT(15)
tagOf_SimplSwitch SimplDoLambdaEtaExpansion = ILIT(16)
tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(29)
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
-{-
-tagOf_SimplSwitch Extra__SimplFlag1 = ILIT(26)
-tagOf_SimplSwitch Extra__SimplFlag2 = ILIT(27)
-tagOf_SimplSwitch Extra__SimplFlag3 = ILIT(28)
-tagOf_SimplSwitch Extra__SimplFlag4 = ILIT(29)
-tagOf_SimplSwitch Extra__SimplFlag5 = ILIT(30)
-tagOf_SimplSwitch Extra__SimplFlag6 = ILIT(31)
-tagOf_SimplSwitch Extra__SimplFlag8 = ILIT(32)
--}
-
-tagOf_SimplSwitch _ = case (panic "tagOf_SimplSwitch") of -- BUG avoidance
- s -> tagOf_SimplSwitch s
+tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch"
lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend)
\end{code}
%************************************************************************
%* *
-\subsection[CmdLineOpts-lookup]{Switch lookup}
+\subsection{Switch lookup}
%* *
%************************************************************************
\begin{code}
-isAmong :: [GlobalSwitch] -> GlobalSwitch -> SwitchResult
isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
-isAmong on_switches
- = let
- tidied_on_switches = foldl rm_dups [] on_switches
-
- sw_tbl :: Array Int SwitchResult
-
- sw_tbl = (array (0, lAST_SWITCH_TAG) -- bounds...
- all_undefined)
- // defined_elems
-
- all_undefined = [ i := SwBool False | i <- [0 .. lAST_SWITCH_TAG ] ]
-
- defined_elems = map mk_assoc_elem tidied_on_switches
- in
-#ifndef __GLASGOW_HASKELL__
- \ switch -> sw_tbl ! IBOX((tagOf_Switch switch)) -- but this is fast!
-#else
- -- and this is faster!
- -- (avoid some unboxing, bounds checking, and other horrible things:)
- case sw_tbl of { _Array bounds_who_needs_'em stuff ->
- \ switch ->
- case (indexArray# stuff (tagOf_Switch switch)) of
- _Lift v -> v
- }
-#endif
- where
- mk_assoc_elem k@(ProduceC str) = IBOX(tagOf_Switch k) := SwString str
- mk_assoc_elem k@(ProduceS str) = IBOX(tagOf_Switch k) := SwString str
- mk_assoc_elem k@(ProduceHi str) = IBOX(tagOf_Switch k) := SwString str
---UNUSED: mk_assoc_elem k@(ProduceHu str) = IBOX(tagOf_Switch k) := SwString str
- mk_assoc_elem k@(SccGroup str) = IBOX(tagOf_Switch k) := SwString str
- mk_assoc_elem k@(AsmTarget str) = IBOX(tagOf_Switch k) := SwString str
- mk_assoc_elem k@(EnsureSplittableC str) = IBOX(tagOf_Switch k) := SwString str
-
- mk_assoc_elem k@(UnfoldingUseThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
- mk_assoc_elem k@(UnfoldingCreationThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
- mk_assoc_elem k@(UnfoldingOverrideThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
-
- mk_assoc_elem k@(ReturnInRegsThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
-
- mk_assoc_elem k = IBOX(tagOf_Switch k) := SwBool True -- I'm here, Mom!
-
- -- cannot have duplicates if we are going to use the array thing
-
- rm_dups switches_so_far switch
- = if switch `is_elem` switches_so_far
- then switches_so_far
- else switch : switches_so_far
- where
- sw `is_elem` [] = False
- sw `is_elem` (s:ss) = (tagOf_Switch sw) _EQ_ (tagOf_Switch s)
- || sw `is_elem` ss
-\end{code}
-
-Same thing for @SimplifierSwitches@; for efficiency reasons, we
-probably do {\em not} want something overloaded.
- \begin{code}
isAmongSimpl on_switches
= let
tidied_on_switches = foldl rm_dups [] on_switches
defined_elems = map mk_assoc_elem tidied_on_switches
in
-#ifndef __GLASGOW_HASKELL__
- \ switch -> sw_tbl ! IBOX((tagOf_SimplSwitch switch)) -- but this is fast!
-#else
- -- and this is faster!
-- (avoid some unboxing, bounds checking, and other horrible things:)
case sw_tbl of { _Array bounds_who_needs_'em stuff ->
\ switch ->
case (indexArray# stuff (tagOf_SimplSwitch switch)) of
_Lift v -> v
}
-#endif
where
mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) := SwInt lvl
mk_assoc_elem k@(SimplUnfoldingUseThreshold i) = IBOX(tagOf_SimplSwitch k) := SwInt i
%************************************************************************
%* *
-\subsection[CmdLineOpts-misc]{Misc functions for command-line options}
+\subsection{Misc functions for command-line options}
%* *
%************************************************************************
_ -> True
stringSwitchSet :: (switch -> SwitchResult)
- -> (String -> switch)
- -> Maybe String
+ -> (FAST_STRING -> switch)
+ -> Maybe FAST_STRING
stringSwitchSet lookup_fn switch
= case (lookup_fn (switch (panic "stringSwitchSet"))) of
-> Maybe Int
intSwitchSet lookup_fn switch
- = -- pprTrace "intSwitchSet:" (ppInt (IBOX (tagOf_Switch (switch (panic "xxx"))))) $
- case (lookup_fn (switch (panic "intSwitchSet"))) of
+ = case (lookup_fn (switch (panic "intSwitchSet"))) of
SwInt int -> Just int
_ -> Nothing
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ErrUtils where
-import Bag(Bag)
-import Pretty(PprStyle, PrettyRep)
-import SrcLoc(SrcLoc)
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-addErrLoc :: SrcLoc -> [Char] -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep
-addShortErrLocLine :: SrcLoc -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep
-dontAddErrLoc :: [Char] -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep
-pprBagOfErrors :: PprStyle -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-
%
\section[ErrsUtils]{Utilities for error reporting}
-This is an internal module---access to these functions is through
-@Errors@.
-
-DPH errors are in here, too.
-
\begin{code}
#include "HsVersions.h"
-module ErrUtils where
+module ErrUtils (
+
+ Error(..),
+ addErrLoc, addShortErrLocLine,
+ dontAddErrLoc, pprBagOfErrors,
+
+ TcError(..), TcWarning(..), Message(..),
+ mkTcErr, arityErr
-import Bag ( Bag, bagToList )
-import Outputable
-import Pretty -- to pretty-print error messages
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
+ ) where
+
+import Ubiq{-uitous-}
+
+import Bag ( bagToList )
+import PprStyle ( PprStyle(..) )
+import Pretty
+import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instance-} )
\end{code}
\begin{code}
-type Error = PprStyle -> Pretty
+type Error = PprStyle -> Pretty
addErrLoc :: SrcLoc -> String -> Error -> Error
addErrLoc locn title rest_of_err_msg sty
pprBagOfErrors sty bag_of_errors
= let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) in
ppAboves (map (\ p -> ppAbove ppSP p) pretties)
+\end{code}
+
+TypeChecking Errors
+~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+type Message = PprStyle -> Pretty
+type TcError = Message
+type TcWarning = Message
+
+
+mkTcErr :: SrcLoc -- Where
+ -> [Message] -- Context
+ -> Message -- What went wrong
+ -> TcError -- The complete error report
+
+mkTcErr locn ctxt msg sty
+ = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
+ 4 (ppAboves [msg sty | msg <- ctxt])
+
-#ifdef DPH
-addWarningLoc :: SrcLoc -> Error -> Error
-addWarningLoc locn rest_of_err_msg sty
- = ppHang (ppBesides [ppStr "*** Warning *** ",
- ppr PprForUser locn,ppStr ": "])
- 4 (ppAbove (rest_of_err_msg sty)
- (ppSP))
-
-addWarning :: Error -> Error
-addWarning rest_of_err_msg sty
- = ppBeside (ppStr "*** Warning *** : ")
- (rest_of_err_msg sty)
-#endif {- Data Parallel Haskell -}
+arityErr kind name n m sty =
+ ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
+ n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
+ where
+ errmsg = kind ++ " has too " ++ quantity ++ " arguments"
+ quantity | m < n = "few"
+ | otherwise = "many"
+ n_arguments | n == 0 = ppStr "no arguments"
+ | n == 1 = ppStr "1 argument"
+ | True = ppCat [ppInt n, ppStr "arguments"]
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Errors where
-import Bag(Bag)
-import CharSeq(CSeq)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..), pprBagOfErrors)
-import ErrsRn(badClassOpErr, badExportNameErr, badImportNameErr, derivingInIfaceErr, derivingNonStdClassErr, dupNamesErr, dupPreludeNameErr, dupSigDeclErr, duplicateImportsInInterfaceErr, inlineInRecursiveBindsErr, methodBindErr, missingSigErr, shadowedNameErr, unknownNameErr, unknownSigDeclErr, weirdImportExportConstraintErr)
-import ErrsTc(UnifyErrContext(..), UnifyErrInfo(..), ambigErr, badMatchErr, badSpecialisationErr, classCycleErr, confusedNameErr, dataConArityErr, defaultErr, derivingEnumErr, derivingIxErr, derivingWhenInstanceExistsErr, dupInstErr, genCantGenErr, instTypeErr, lurkingRank2Err, methodTypeLacksTyVarErr, naughtyCCallContextErr, noInstanceErr, nonBoxedPrimCCallErr, notAsPolyAsSigErr, preludeInstanceErr, reduceErr, sigContextsErr, specCtxtGroundnessErr, specDataNoSpecErr, specDataUnboxedErr, specGroundnessErr, specInstUnspecInstNotFoundErr, topLevelUnboxedDeclErr, tyConArityErr, typeCycleErr, underAppliedTyErr, unifyErr, varyingArgsErr)
-import GenSpecEtc(SignatureInfo)
-import HsBinds(Binds, MonoBinds, ProtoNameMonoBinds(..), RenamedSig(..), Sig)
-import HsExpr(ArithSeqInfo, Expr, Qual, RenamedExpr(..), TypecheckedExpr(..))
-import HsImpExp(IE)
-import HsLit(Literal)
-import HsMatches(GRHS, GRHSsAndBinds, Match, RenamedGRHS(..), RenamedGRHSsAndBinds(..), RenamedMatch(..))
-import HsPat(InPat, ProtoNamePat(..), RenamedPat(..), TypecheckedPat)
-import HsPragmas(ClassOpPragmas, GenPragmas)
-import HsTypes(PolyType)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import SimplEnv(UnfoldingGuidance)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(TauType(..), UniType)
-import Unique(Unique)
-data Bag a
-data Class
-data ClassOp
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data UnifyErrContext
- = PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType
-data UnifyErrInfo = UnifyMisMatch UniType UniType | TypeRec TyVar UniType | UnifyListMisMatch [UniType] [UniType] | UnifyUnboxedMisMatch UniType UniType
-data SignatureInfo
-data MonoBinds a b
-type ProtoNameMonoBinds = MonoBinds ProtoName (InPat ProtoName)
-type RenamedSig = Sig Name
-data Sig a
-data Expr a b
-type RenamedExpr = Expr Name (InPat Name)
-type TypecheckedExpr = Expr Id TypecheckedPat
-data IE
-data GRHS a b
-data GRHSsAndBinds a b
-data Match a b
-type RenamedGRHS = GRHS Name (InPat Name)
-type RenamedGRHSsAndBinds = GRHSsAndBinds Name (InPat Name)
-type RenamedMatch = Match Name (InPat Name)
-data InPat a
-type ProtoNamePat = InPat ProtoName
-type RenamedPat = InPat Name
-data TypecheckedPat
-data GenPragmas a
-data Id
-data Inst
-data Labda a
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-data SrcLoc
-data TyCon
-data TyVar
-data TyVarTemplate
-type TauType = UniType
-data UniType
-pprBagOfErrors :: PprStyle -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-badClassOpErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-badExportNameErr :: [Char] -> [Char] -> PprStyle -> Int -> Bool -> PrettyRep
-badImportNameErr :: [Char] -> [Char] -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-dupNamesErr :: [Char] -> [(ProtoName, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
-dupPreludeNameErr :: [Char] -> (ProtoName, SrcLoc) -> PprStyle -> Int -> Bool -> PrettyRep
-dupSigDeclErr :: [Sig Name] -> PprStyle -> Int -> Bool -> PrettyRep
-duplicateImportsInInterfaceErr :: [Char] -> [ProtoName] -> PprStyle -> Int -> Bool -> PrettyRep
-inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
-methodBindErr :: MonoBinds ProtoName (InPat ProtoName) -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-missingSigErr :: SrcLoc -> ProtoName -> PprStyle -> Int -> Bool -> PrettyRep
-shadowedNameErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unknownNameErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unknownSigDeclErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-ambigErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-badSpecialisationErr :: [Char] -> [Char] -> Int -> [Labda UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-classCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
-confusedNameErr :: [Char] -> Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-dataConArityErr :: Id -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-defaultErr :: [Inst] -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
-derivingEnumErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-derivingIxErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-derivingWhenInstanceExistsErr :: Class -> TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> PprStyle -> Int -> Bool -> PrettyRep
-genCantGenErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-instTypeErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-lurkingRank2Err :: Name -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-methodTypeLacksTyVarErr :: TyVarTemplate -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-naughtyCCallContextErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-noInstanceErr :: Inst -> PprStyle -> Int -> Bool -> PrettyRep
-nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-preludeInstanceErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-reduceErr :: [Inst] -> UnifyErrContext -> PprStyle -> Int -> Bool -> PrettyRep
-sigContextsErr :: [SignatureInfo] -> PprStyle -> Int -> Bool -> PrettyRep
-specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-specGroundnessErr :: UnifyErrContext -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
-specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-topLevelUnboxedDeclErr :: Id -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-tyConArityErr :: Name -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-typeCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
-underAppliedTyErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-varyingArgsErr :: Name -> [Match Name (InPat Name)] -> PprStyle -> Int -> Bool -> PrettyRep
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Errors]{Error reporting}
-
-This module now merely re-exports the work of @ErrsRn@ and @ErrsTc@;
-this is the public interface. (WDP 94/06)
-
-\begin{code}
-#include "HsVersions.h"
-
-module Errors (
- Error(..),
- pprBagOfErrors,
-
- -- renamer errors:
- badClassOpErr,
- badExportNameErr,
- badImportNameErr,
- derivingInIfaceErr,
- derivingNonStdClassErr,
- dupNamesErr,
- dupPreludeNameErr,
- dupSigDeclErr,
- duplicateImportsInInterfaceErr,
- inlineInRecursiveBindsErr,
- missingSigErr,
--- mismatchedPragmasErr, UNUSED
- shadowedNameErr,
- unknownNameErr,
- unknownSigDeclErr,
- weirdImportExportConstraintErr,
-
- -- typechecker errors:
- ambigErr,
- badMatchErr,
- badSpecialisationErr,
- confusedNameErr,
- classCycleErr,
- typeCycleErr,
- dataConArityErr,
- defaultErr,
- derivingEnumErr,
- derivingIxErr,
- derivingWhenInstanceExistsErr,
--- derivingNoSuperClassInstanceErr, UNUSED
- dupInstErr,
--- extraMethodsErr, UNUSED
- genCantGenErr,
--- genPrimTyVarErr, UNUSED
- noInstanceErr,
--- instOpErr, UNUSED
- instTypeErr,
--- methodInstErr, UNUSED
- methodBindErr,
- lurkingRank2Err,
- methodTypeLacksTyVarErr,
--- missingClassOpErr, UNUSED
- naughtyCCallContextErr,
- nonBoxedPrimCCallErr,
- notAsPolyAsSigErr,
--- patMatchWithPrimErr, UNUSED
- preludeInstanceErr,
--- purelyLocalErr, UNUSED
- reduceErr,
- sigContextsErr,
- specGroundnessErr,
- specCtxtGroundnessErr,
- specDataNoSpecErr,
- specDataUnboxedErr,
- specInstUnspecInstNotFoundErr,
- topLevelUnboxedDeclErr,
- tyConArityErr,
- underAppliedTyErr,
- unifyErr,
- varyingArgsErr,
-#ifdef DPH
- podCompLhsError,
- pprPodizedWarning,
- PodWarning,
-#endif {- Data Parallel Haskell -}
-
- UnifyErrContext(..),
- UnifyErrInfo(..),
-
- -- and to make the interface self-sufficient
- Bag, Class, ClassOp, MonoBinds, ProtoNameMonoBinds(..), Sig,
- RenamedSig(..), Expr, RenamedExpr(..), GRHS, RenamedGRHS(..),
- GRHSsAndBinds, RenamedGRHSsAndBinds(..), Match, IE,
- RenamedMatch(..), InPat, ProtoNamePat(..), RenamedPat(..),
- GenPragmas, Id, Inst, Name, PprStyle, Pretty(..), PrettyRep,
- ProtoName, SrcLoc, TyCon, TyVar, TyVarTemplate, UniType,
- TauType(..), Maybe, SignatureInfo, TypecheckedPat,
- TypecheckedExpr(..)
- ) where
-
--- I don't know how much of this is needed... (WDP 94/06)
-
-import ErrsRn
-import ErrsTc
-import ErrUtils
-
-import AbsSyn -- we print a bunch of stuff in here
-import UniType ( UniType(..) ) -- Concrete, to make some errors
- -- more informative.
-import AbsUniType ( TyVar, TyVarTemplate, TyCon,
- TauType(..), Class, ClassOp
- IF_ATTACK_PRAGMAS(COMMA pprUniType)
- )
-import Bag ( Bag, bagToList )
-import GenSpecEtc ( SignatureInfo(..) )
-import HsMatches ( pprMatches, pprMatch, pprGRHS )
-import Id ( getIdUniType, Id, isSysLocalId )
-import Inst ( getInstOrigin, getDictClassAndType, Inst )
-import Maybes ( Maybe(..) )
-import Name ( cmpName )
-import Outputable
-import Pretty -- to pretty-print error messages
-#ifdef DPH
-import PodizeMonad ( PodWarning(..) )
-#endif {- Data Parallel Haskell -}
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ErrsRn where
-import HsBinds(MonoBinds, Sig)
-import HsImpExp(IE)
-import HsPat(InPat)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import ProtoName(ProtoName)
-import SrcLoc(SrcLoc)
-badClassOpErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-badExportNameErr :: [Char] -> [Char] -> PprStyle -> Int -> Bool -> PrettyRep
-badImportNameErr :: [Char] -> [Char] -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-dupNamesErr :: [Char] -> [(ProtoName, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
-dupPreludeNameErr :: [Char] -> (ProtoName, SrcLoc) -> PprStyle -> Int -> Bool -> PrettyRep
-dupSigDeclErr :: [Sig Name] -> PprStyle -> Int -> Bool -> PrettyRep
-duplicateImportsInInterfaceErr :: [Char] -> [ProtoName] -> PprStyle -> Int -> Bool -> PrettyRep
-inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
-methodBindErr :: MonoBinds ProtoName (InPat ProtoName) -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-missingSigErr :: SrcLoc -> ProtoName -> PprStyle -> Int -> Bool -> PrettyRep
-shadowedNameErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unknownNameErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unknownSigDeclErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[ErrsRn]{Reporting errors from the renamer}
-
-This is an internal module---access to these functions is through
-@Errors@.
-
-\begin{code}
-#include "HsVersions.h"
-
-module ErrsRn where
-
-import AbsSyn -- we print a bunch of stuff in here
-import AbsUniType ( TyVarTemplate )
-import UniType ( UniType(..) )
- -- UniType is concrete, to make some errors
- -- more informative.
-import ErrUtils
-import Name ( cmpName )
-import Outputable
-import Pretty -- to pretty-print error messages
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
-\end{code}
-
-\begin{code}
-badClassOpErr :: Name{-class-} -> ProtoName{-op-} -> SrcLoc -> Error
- -- Class op expected but something else found
-badClassOpErr clas op locn
- = addErrLoc locn "" ( \ sty ->
- ppBesides [ppChar '`', ppr sty op, ppStr "' is not an operation of class `",
- ppr sty clas, ppStr "'."] )
-
-----------------------------------------------------------------
-badExportNameErr :: String -> String -> Error
-
-badExportNameErr name whats_wrong
- = dontAddErrLoc
- "Error in the export list" ( \ sty ->
- ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
-
-----------------------------------------------------------------
-badImportNameErr :: String -> String -> String -> SrcLoc -> Error
-
-badImportNameErr mod name whats_wrong locn
- = addErrLoc locn
- ("Error in an import list for the module `"++mod++"'") ( \ sty ->
- ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
-
-----------------------------------------------------------------
-derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> Error
- -- GHC doesn't support "deriving" in interfaces
-
-derivingInIfaceErr ty deriveds locn
- = addErrLoc locn "Glasgow Haskell doesn't support `deriving' in interfaces" ( \ sty ->
- ppBesides [ ppStr "type: ", ppr sty ty,
- ppStr "; derived: ", interpp'SP sty deriveds ] )
-
-----------------------------------------------------------------
-derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> Error
- -- if "deriving" specified for a non-standard class
-
-derivingNonStdClassErr tycon clas locn
- = addErrLoc locn "Can't have a derived instance of this class" ( \ sty ->
- ppBesides [ppStr "type constructor: ", ppr sty tycon,
- ppStr "; class: ", ppr sty clas] )
-
-----------------------------------------------------------------
-dupNamesErr :: String -> [(ProtoName,SrcLoc)] -> Error
-
-dupNamesErr descriptor ((first_pname,locn1) : dup_things) sty
- = ppAboves (first_item : map dup_item dup_things)
- where
- first_item
- = ppBesides [ ppr PprForUser locn1,
- ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ",
- ppr sty first_pname ]
-
- dup_item (pname, locn)
- = ppBesides [ ppr PprForUser locn,
- ppStr ": here was another declaration of `", ppr sty pname, ppStr "'" ]
-
-----------------------------------------------------------------
-dupPreludeNameErr :: String -> (ProtoName, SrcLoc) -> Error
-
-dupPreludeNameErr descriptor (nm, locn)
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ ppStr "A conflict with a Prelude ", ppStr descriptor,
- ppStr ": ", ppr sty nm ])
-
-----------------------------------------------------------------
-dupSigDeclErr :: [RenamedSig] -> Error
- -- Duplicate signatures in a group; the sigs have locns on them
-dupSigDeclErr sigs
- = let
- undup_sigs = fst (removeDups cmp_sig sigs)
- in
- addErrLoc locn1
- ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty ->
- ppAboves (map (ppr sty) undup_sigs) )
- where
- (what_it_is, locn1)
- = case (head sigs) of
- Sig _ _ _ loc -> ("type signature",loc)
- ClassOpSig _ _ _ loc -> ("class-method type signature", loc)
- SpecSig _ _ _ loc -> ("SPECIALIZE pragma",loc)
- InlineSig _ _ loc -> ("INLINE pragma",loc)
- MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc)
-
- cmp_sig a b = get_name a `cmpName` get_name b
-
- get_name (Sig n _ _ _) = n
- get_name (ClassOpSig n _ _ _) = n
- get_name (SpecSig n _ _ _) = n
- get_name (InlineSig n _ _) = n
- get_name (MagicUnfoldingSig n _ _) = n
-
-----------------------------------------------------------------
-duplicateImportsInInterfaceErr :: String -> [ProtoName] -> Error
-duplicateImportsInInterfaceErr iface dups
- = panic "duplicateImportsInInterfaceErr: NOT DONE YET?"
-
-----------------------------------------------------------------
-inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> Error
-
-inlineInRecursiveBindsErr [(name, locn)]
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "INLINE pragma for a recursive definition: ",
- ppr sty name] )
-inlineInRecursiveBindsErr names_n_locns
- = \ sty ->
- ppHang (ppStr "INLINE pragmas for some recursive definitions:")
- 4 (ppAboves [ ppBesides [ppr PprForUser locn, ppStr ": ", ppr sty n]
- | (n, locn) <- names_n_locns ])
-
-----------------------------------------------------------------
---mismatchedPragmasErr :: (Annotations, SrcLoc)
--- -> (Annotations, SrcLoc)
--- -> Error
-{- UNUSED:
-mismatchedPragmasErr (anns1, _) (anns2, _)
- = dontAddErrLoc "Mismatched pragmas from interfaces" ( \ sty ->
- ppSep [ppr sty anns1, ppr sty anns2] )
--}
-
-----------------------------------------------------------------
-shadowedNameErr :: Name -> SrcLoc -> Error
-shadowedNameErr shadow locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "more than one value with the same name (shadowing): ",
- ppr sty shadow] )
-
-----------------------------------------------------------------
-unknownNameErr :: String -> ProtoName -> SrcLoc -> Error
-unknownNameErr descriptor undef_thing locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ",
- ppr sty undef_thing] )
-
-----------------------------------------------------------------
-missingSigErr :: SrcLoc -> ProtoName -> Error
- -- Top-level definition without a type signature
- -- (when SigsRequired flag is in use)
-missingSigErr locn var
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "a definition but no type signature for `",
- ppr sty var,
- ppStr "'."])
-
-----------------------------------------------------------------
-unknownSigDeclErr :: String -> ProtoName -> SrcLoc -> Error
- -- Signature/Pragma given for unknown variable
-unknownSigDeclErr flavor var locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr flavor, ppStr " but no definition for `",
- ppr sty var,
- ppStr "'."])
-
-----------------------------------------------------------------
-weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> Error
-
-weirdImportExportConstraintErr thing constraint locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "Illegal import/export constraint on `",
- ppr sty thing,
- ppStr "': ", ppr PprForUser constraint])
-
-----------------------------------------------------------------
-methodBindErr :: ProtoNameMonoBinds -> SrcLoc -> Error
-methodBindErr mbind locn
- = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
- (\ sty -> ppr sty mbind)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ErrsTc where
-import Class(Class)
-import GenSpecEtc(SignatureInfo)
-import HsExpr(Expr)
-import HsMatches(GRHS, GRHSsAndBinds, Match)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-data UnifyErrContext
- = PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType
-data UnifyErrInfo = UnifyMisMatch UniType UniType | TypeRec TyVar UniType | UnifyListMisMatch [UniType] [UniType] | UnifyUnboxedMisMatch UniType UniType
-ambigErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-badSpecialisationErr :: [Char] -> [Char] -> Int -> [Labda UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-classCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
-confusedNameErr :: [Char] -> Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-dataConArityErr :: Id -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-defaultErr :: [Inst] -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
-derivingEnumErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-derivingIxErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-derivingWhenInstanceExistsErr :: Class -> TyCon -> PprStyle -> Int -> Bool -> PrettyRep
-dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> PprStyle -> Int -> Bool -> PrettyRep
-genCantGenErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-instTypeErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-lurkingRank2Err :: Name -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-methodTypeLacksTyVarErr :: TyVarTemplate -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-naughtyCCallContextErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-noInstanceErr :: Inst -> PprStyle -> Int -> Bool -> PrettyRep
-nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-preludeInstanceErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-reduceErr :: [Inst] -> UnifyErrContext -> PprStyle -> Int -> Bool -> PrettyRep
-sigContextsErr :: [SignatureInfo] -> PprStyle -> Int -> Bool -> PrettyRep
-specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
-specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-specGroundnessErr :: UnifyErrContext -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
-specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-topLevelUnboxedDeclErr :: Id -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-tyConArityErr :: Name -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-typeCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
-underAppliedTyErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
-varyingArgsErr :: Name -> [Match Name (InPat Name)] -> PprStyle -> Int -> Bool -> PrettyRep
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[ErrsTc]{Reporting errors from the typechecker}
-
-This is an internal module---access to these functions is through
-@Errors@.
-
-DPH errors are in here, too.
-
-\begin{code}
-#include "HsVersions.h"
-
-module ErrsTc (
- UnifyErrContext(..), UnifyErrInfo(..),
-
- ambigErr,
- badMatchErr,
- badSpecialisationErr,
- classCycleErr,
- confusedNameErr,
- dataConArityErr,
- defaultErr,
- derivingEnumErr,
- derivingIxErr,
- derivingWhenInstanceExistsErr,
- dupInstErr,
- genCantGenErr,
- instTypeErr,
- lurkingRank2Err,
- methodTypeLacksTyVarErr,
- naughtyCCallContextErr,
- noInstanceErr,
- nonBoxedPrimCCallErr,
- notAsPolyAsSigErr,
- preludeInstanceErr,
- reduceErr,
- sigContextsErr,
- specCtxtGroundnessErr,
- specDataNoSpecErr,
- specDataUnboxedErr,
- specGroundnessErr,
- specInstUnspecInstNotFoundErr,
- topLevelUnboxedDeclErr,
- tyConArityErr,
- typeCycleErr,
- underAppliedTyErr,
- unifyErr,
- varyingArgsErr
- ) where
-
-import AbsSyn -- we print a bunch of stuff in here
-import UniType ( UniType(..) ) -- Concrete, to make some errors
- -- more informative.
-import ErrUtils
-import AbsUniType ( extractTyVarsFromTy, pprMaybeTy,
- TyVar, TyVarTemplate, TyCon,
- TauType(..), Class, ClassOp
- IF_ATTACK_PRAGMAS(COMMA pprUniType)
- )
-import Bag ( Bag, bagToList )
-import GenSpecEtc ( SignatureInfo(..) )
-import HsMatches ( pprMatches, pprMatch, pprGRHS )
-import Id ( getIdUniType, Id, isSysLocalId )
-import Inst ( getInstOrigin, getDictClassAndType, Inst )
-import Name ( cmpName )
-import Outputable
-import Pretty -- to pretty-print error messages
-#ifdef DPH
-import PodizeMonad ( PodWarning(..) )
-#endif {- Data Parallel Haskell -}
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
-\end{code}
-
-\begin{code}
-ambigErr :: [Inst] -> Error
-ambigErr insts@(inst1:_)
- = addErrLoc loc1 "Ambiguous overloading" ( \ sty ->
- ppAboves (map (ppr_inst sty) insts) )
- where
- (loc1, _) = getInstOrigin inst1
-
-ppr_inst sty inst
- = let
- (clas, ty) = getDictClassAndType inst
- (locn, msg) = getInstOrigin inst
- in
- ppSep [ ppBesides [ppStr "class `", ppr sty clas,
- ppStr "', type `", ppr sty ty, ppStr "'"],
- ppBesides [ppStr "(", msg sty, ppStr ")"] ]
-
-----------------------------------------------------------------
-badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> Error
-badMatchErr sig_ty inferred_ty ctxt locn
- = addErrLoc locn "Type signature mismatch" ( \ sty ->
- let
- thing
- = case ctxt of
- SigCtxt id _ -> ppBesides [ppChar '`', ppr sty id, ppChar '\'']
- MethodSigCtxt op _ -> ppBesides [ppStr "class method `", ppr sty op, ppStr "'"]
- ExprSigCtxt _ _ -> ppStr "an expression"
- Rank2ArgCtxt _ _ -> ppStr "an expression with rank-2 polymorphic type(!)"
- ctxt -> pprUnifyErrContext sty ctxt
- -- the latter is ugly, but better than a patt-match failure
- in
- ppAboves [ppSep [
- ppStr "Signature for", thing, ppStr "doesn't match its inferred type."
- ],
- ppHang (ppStr "Signature:") 4 (ppr sty sig_ty),
- ppHang (ppStr "Inferred type:") 4 (ppr sty inferred_ty)
- ] )
-
-----------------------------------------------------------------
-badSpecialisationErr :: String -> String -> Int -> [Maybe UniType] -> SrcLoc -> Error
-
-badSpecialisationErr flavor messg no_tyvars ty_maybes locn
- = addErrLoc locn ("Bad "++flavor++" specialisation pragma: "++messg) ( \ sty ->
- ppStr "MSG NOT DONE YET"
- )
-
-----------------------------------------------------------------
-confusedNameErr :: String
- -> Name -- the confused name
- -> SrcLoc
- -> Error
-confusedNameErr msg nm locn
- = addErrLoc locn msg ( \ sty ->
- ppr sty nm )
-{-
- where
- msg = if flag then "Type constructor used where a class is expected"
- else "Class used where a type constructor is expected"
--}
-
-----------------------------------------------------------------
-typeCycleErr :: [[(Pretty, SrcLoc)]] -> Error
-typeCycleErr = cycleErr "The following type synonyms refer to themselves:"
-
-classCycleErr :: [[(Pretty, SrcLoc)]] -> Error
-classCycleErr = cycleErr "The following classes form a cycle:"
-
-cycleErr :: String -> [[(Pretty, SrcLoc)]] -> Error
-cycleErr msg cycles sty
- = ppHang (ppStr msg)
- 4 (ppAboves (map pp_cycle cycles))
- where
- pp_cycle things = ppAboves (map pp_thing things)
- pp_thing (thing,loc) = ppHang (ppBesides [ppr PprForUser loc, ppStr ": "]) 4 thing
-
-----------------------------------------------------------------
-defaultErr :: [Inst]{-dicts-} -> [UniType] -> Error
- -- when default-resolution fails...
-
-defaultErr dicts defaulting_tys sty
- = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
- 4 (ppAboves [
- ppHang (ppStr "Conflicting:")
- 4 (ppInterleave ppSemi (map (ppr_inst sty) dicts)),
- ppHang (ppStr "Defaulting types :")
- 4 (ppr sty defaulting_tys),
- ppStr "([Int, Double] is the default list of defaulting types.)" ])
-
-----------------------------------------------------------------
-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 "'"] )
-
-----------------------------------------------------------------
-derivingWhenInstanceExistsErr :: Class -> TyCon -> Error
-derivingWhenInstanceExistsErr clas tycon
- = addErrLoc (getSrcLoc tycon) "`deriving' when an instance also exists" ( \ sty ->
- ppBesides [ppStr "class `", ppr sty clas,
- ppStr "', type `", ppr sty tycon, ppStr "'"] )
-
-----------------------------------------------------------------
-{- UNUSED:
-derivingNoSuperClassInstanceErr :: Class -> TyCon -> Class -> Error
-derivingNoSuperClassInstanceErr clas tycon super_class
- = addErrLoc (getSrcLoc tycon) "No instance for a superclass in a `deriving'" ( \ sty ->
- ppSep [ppBesides [ppStr "the superclass `", ppr sty super_class, ppStr "' has no instance"],
- ppBesides [ppStr "at the type `", ppr sty tycon, ppStr "';"],
- ppBesides [ppStr "(the class being \"derived\" is `", ppr sty clas, ppStr "')"]
- ])
--}
-
-----------------------------------------------------------------
-dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error
-dupInstErr (clas, info1@(ty1, locn1), info2@(ty2, locn2))
- -- Overlapping/duplicate instances for given class; msg could be more glamourous
- = addErrLoc locn1 "Duplicate/overlapping instances" ( \ sty ->
- ppSep [ ppBesides [ppStr "class `", ppr sty clas, ppStr "',"],
- showOverlap sty info1 info2] )
-
-----------------------------------------------------------------
-{- UNUSED?
-extraMethodsErr :: [Id] {-dicts-} -> SrcLoc -> Error
- -- when an instance decl has binds for methods that aren't in the class decl
-extraMethodsErr extra_methods locn
- = addErrLoc locn "Extra methods in instance declaration" ( \ sty ->
- interpp'SP sty extra_methods )
--}
-
-----------------------------------------------------------------
-genCantGenErr :: [Inst] -> Error
-genCantGenErr insts@(inst1:_)
- = addErrLoc loc1 "Cannot generalise these overloadings (in a _ccall_):" ( \ sty ->
- ppAboves (map (ppr_inst sty) insts) )
- where
- (loc1, _) = getInstOrigin inst1
-
-----------------------------------------------------------------
-{- UNUSED:
-genPrimTyVarErr :: [TyVar] -> SrcLoc -> Error
- -- Attempt to generalise over a primitive type variable
-
-genPrimTyVarErr tyvars locn
- = addErrLoc locn "These primitive type variables can't be made more general" ( \ sty ->
- ppAbove (interpp'SP sty tyvars)
- (ppStr "(Solution: add a type signature.)") )
--}
-----------------------------------------------------------------
-noInstanceErr :: Inst -> Error
-noInstanceErr inst
- = let (clas, ty) = getDictClassAndType inst
- (locn, msg) = getInstOrigin inst
- in
- addErrLoc locn "No such instance" ( \ sty ->
- ppSep [ ppBesides [ppStr "class `", ppr sty clas,
- ppStr "', type `", ppr sty ty, ppStr "'"],
- ppBesides [ppStr "(", msg sty, ppStr ")"] ]
- )
-
-----------------------------------------------------------------
-{- UNUSED:
-instOpErr :: Id -> Class -> TyCon -> Error
-
-instOpErr dict clas tycon
- -- no instance of "Class" for "TyCon"
- -- the Id is the offending dictionary; has src location
- -- (and we could get the Class and TyCon from it, but
- -- since we already have it at hand ...)
- = addErrLoc (getSrcLoc dict) "Invalid instance" ( \ sty ->
- ppBesides [ ppStr "There is no instance of `", ppr sty tycon,
- ppStr "' for class `",
- ppr sty clas, ppChar '\'' ] )
--}
-
-----------------------------------------------------------------
-instTypeErr :: UniType -> SrcLoc -> Error
-instTypeErr ty locn
- = addShortErrLocLine locn (\ sty ->
- let
- rest_of_msg = ppStr "' cannot be used as the instance type\n in an instance declaration."
- in
- case ty of
- UniSyn tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
- UniTyVar tv -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
- other -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
- )
-
-----------------------------------------------------------------
-lurkingRank2Err :: Name -> UniType -> SrcLoc -> Error
-lurkingRank2Err name ty locn
- = addErrLoc locn "Illegal use of a non-Hindley-Milner variable" ( \ sty ->
- ppAboves [
- ppBesides [ppStr "The variable is `", ppr sty name, ppStr "'."],
- ppStr "Its type does not have all its for-alls at the top",
- ppBesides [ppStr "(the type is `", ppr sty ty, ppStr "'),"],
- ppStr "nor is it a full application of a rank-2-typed variable.",
- ppStr "(Most common cause: `_runST' or `_build' not applied to an argument.)"])
-
-----------------------------------------------------------------
-{- UNUSED:
-methodInstErr :: (ClassOp, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error
-methodInstErr (class_op, info1, info2) sty
- -- Two instances for given class op
- = ppHang (ppBesides [ ppStr "The class method `", ppr sty class_op, ppStr "' has been given more than one definition for"])
- 4 (showOverlap sty info1 info2)
--}
-
-showOverlap :: PprStyle -> (UniType, SrcLoc) -> (UniType, SrcLoc) -> Pretty
-showOverlap sty (ty1,loc1) (ty2,loc2)
- = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
- ppBeside (ppStr "at ") (ppr sty loc1),
- ppBeside (ppStr "and ") (ppr sty loc2)]
-
-----------------------------------------------------------------
-methodTypeLacksTyVarErr :: TyVarTemplate -> String -> SrcLoc -> Error
-methodTypeLacksTyVarErr tyvar method_name locn
- = addErrLoc locn "Method's type doesn't mention the class type variable" (\ sty ->
- ppAboves [ppBeside (ppStr "Class type variable: ") (ppr sty tyvar),
- ppBeside (ppStr "Method: ") (ppStr method_name)] )
-
-----------------------------------------------------------------
-{- UNUSED:
-missingClassOpErr :: Id -> [ClassOp] -> SrcLoc -> Error
-missingClassOpErr op classops locn
- = addErrLoc locn "Undefined class method" ( \ sty ->
- ppBesides [ ppr sty op, ppStr "; valid method(s):",
- interpp'SP sty classops ] )
--}
-
-----------------------------------------------------------------
-naughtyCCallContextErr :: Name -> SrcLoc -> Error
-naughtyCCallContextErr clas_name locn
- = addErrLoc locn "Can't use this class in a context" (\ sty ->
- ppr sty clas_name )
-
-----------------------------------------------------------------
-nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> Error
-nonBoxedPrimCCallErr clas inst_ty locn
- = addErrLoc locn "Instance isn't for a `boxed-primitive' type" ( \ sty ->
- ppBesides [ ppStr "class `", ppr sty clas, ppStr "'; type `",
- ppr sty inst_ty, ppStr "'"] )
-
-----------------------------------------------------------------
-notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> Error
-notAsPolyAsSigErr sig_ty mono_tyvars ctxt locn
- = addErrLoc locn "A type signature is more polymorphic than the inferred type" ( \ sty ->
- ppAboves [ ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)",
- pprUnifyErrContext sty ctxt,
- ppHang (ppStr "Monomorphic type variable(s):")
- 4 (interpp'SP sty mono_tyvars),
- ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction"
- ] )
-
-----------------------------------------------------------------
-{- UNUSED:
-patMatchWithPrimErr :: Error
-patMatchWithPrimErr
- = dontAddErrLoc
- "Pattern-bindings may not involve primitive types." ( \ sty ->
- ppNil )
--}
-
-----------------------------------------------------------------
-preludeInstanceErr :: Class -> UniType -> SrcLoc -> Error
-preludeInstanceErr clas ty locn
- = addShortErrLocLine locn ( \ sty ->
- ppHang (ppBesides [ppStr "Illegal instance: for Prelude class `", ppr sty clas,
- ppStr "' and Prelude type `", ppr sty ty, ppStr "'."] )
- 4 (ppStr "(An instance decl must be in the same module as the type decl or the class decl)") )
-
-----------------------------------------------------------------
-{- UNUSED:
-purelyLocalErr :: Name -> SrcLoc -> Error
-purelyLocalErr thing locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "`", ppr sty thing,
- ppStr "' cannot be exported -- it would refer to an unexported local entity."] )
--}
-
-----------------------------------------------------------------
-reduceErr :: [Inst] -> UnifyErrContext -> Error
- -- Used by tcSimplifyCheckLIE
- -- Could not express required dictionaries in terms of the signature
-reduceErr insts ctxt
- = dontAddErrLoc "Type signature lacks context required by inferred type" ( \ sty ->
- ppAboves [
- pprUnifyErrContext sty ctxt,
- ppHang (ppStr "Context reqd: ")
- 4 (ppAboves (map (ppr_inst sty) insts))
- ])
- where
- ppr_inst sty inst
- = let (clas, ty) = getDictClassAndType inst
- (locn, msg) = getInstOrigin inst
- in
- ppSep [ ppBesides [ppr sty locn, ppStr ": ", ppr sty clas, ppSP, ppr sty ty],
- ppBesides [ppStr "(", msg sty, ppStr ")"] ]
-
-----------------------------------------------------------------
-{-
-unexpectedPreludeThingErr :: Outputable a => String -> a -> SrcLoc -> Error
-
-unexpectedPreludeThingErr category thing locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "Prelude ", ppStr category,
- ppStr " not expected here: ", ppr sty thing])
--}
-
-----------------------------------------------------------------
-specGroundnessErr :: UnifyErrContext -> [UniType] -> Error
-
-specGroundnessErr (ValSpecSigCtxt name spec_ty locn) arg_tys
- = addShortErrLocLine locn ( \ sty ->
- ppHang (
- ppSep [ppStr "In the SPECIALIZE pragma for `", ppr sty name,
- ppStr "'... not all type variables were specialised",
- ppStr "to type variables or ground types (nothing in between, please!):"])
- 4 (ppAboves (map (ppr sty) arg_tys))
- )
-
-specGroundnessErr (ValSpecSpecIdCtxt name spec_ty spec locn) arg_tys
- = addShortErrLocLine locn ( \ sty ->
- ppHang (
- ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
- ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"],
- ppStr "... not all type variables were instantiated",
- ppStr "to type variables or ground types (nothing in between, please!):"])
- 4 (ppAboves (map (ppr sty) arg_tys))
- )
-
-----------------------------------------------------------------
-specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> Error
-
-specCtxtGroundnessErr err_ctxt dicts
- = addShortErrLocLine locn ( \ sty ->
- ppHang (
- ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
- ppBesides [ppStr " specialised to the type `", ppr sty spec_ty, ppStr "'"],
- pp_spec_id sty,
- ppStr "... not all overloaded type variables were instantiated",
- ppStr "to ground types:"])
- 4 (ppAboves [ppCat [ppr sty c, ppr sty t]
- | (c,t) <- map getDictClassAndType dicts])
- )
- where
- (name, spec_ty, locn, pp_spec_id)
- = case err_ctxt of
- ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> ppNil)
- ValSpecSpecIdCtxt n ty spec loc ->
- (n, ty, loc,
- \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
-
-----------------------------------------------------------------
-specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> Error
-
-specDataNoSpecErr name arg_tys locn
- = addShortErrLocLine locn ( \ sty ->
- ppHang (
- ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
- ppStr "... no unboxed type arguments in specialisation:"])
- 4 (ppAboves (map (ppr sty) arg_tys))
- )
-
-----------------------------------------------------------------
-specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> Error
-
-specDataUnboxedErr name arg_tys locn
- = addShortErrLocLine locn ( \ sty ->
- ppHang (
- ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
- ppStr "... not all type arguments were specialised to",
- ppStr "specific unboxed types or (boxed) type variables:"])
- 4 (ppAboves (map (ppr sty) arg_tys))
- )
-
-----------------------------------------------------------------
-specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> Error
-
-specInstUnspecInstNotFoundErr clas inst_ty locn
- = addErrLoc locn "No local instance to specialise" ( \ sty ->
- ppBesides [ ppStr "class `", ppr sty clas, ppStr "' at the type `",
- ppr sty inst_ty, ppStr "'"] )
-
-----------------------------------------------------------------
--- The type signatures on a mutually-recursive group of definitions
--- must all have the same context (or none). For example:
--- f :: Eq a => ...
--- g :: (Eq a, Text a) => ...
--- is illegal if f and g are mutually recursive. This also
--- applies to variables bound in the same pattern binding.
-
-sigContextsErr :: [SignatureInfo] -> Error
-
-sigContextsErr infos
- = dontAddErrLoc "A group of type signatures have mismatched contexts" ( \ sty ->
- ppAboves (map (ppr_sig_info sty) infos) )
- where
- ppr_sig_info sty (TySigInfo val tyvars insts tau_ty _)
- = ppHang (ppBeside (ppr sty val) (ppStr " :: "))
- 4 (ppHang (if null insts
- then ppNil
- else ppBesides [ppStr "(", ppInterleave ppComma (map (ppr_inst sty) insts), ppStr ") => "])
- 4 (ppr sty tau_ty))
-
- ppr_inst sty inst
- = let (clas, ty) = getDictClassAndType inst
- (locn, msg) = getInstOrigin inst
- in
- ppCat [ppr sty clas, ppr sty ty]
-
-----------------------------------------------------------------
-topLevelUnboxedDeclErr :: Id -> SrcLoc -> Error
- -- Top level decl of something with a primitive type
-
-topLevelUnboxedDeclErr id locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "The top-level value `", ppr sty id, ppStr "' shouldn't have an unboxed type." ])
-
-----------------------------------------------------------------
-dataConArityErr :: Id -> Int -> Int -> SrcLoc -> Error
-tyConArityErr :: Name -> Int -> Int -> SrcLoc -> Error
-
-tyConArityErr = arityError "Type"
-dataConArityErr = arityError "Constructor"
-
-arityError kind name n m locn =
- addErrLoc locn errmsg
- (\ sty ->
- ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
- n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.'])
- where
- errmsg = kind ++ " has too " ++ quantity ++ " arguments"
- quantity | m < n = "few"
- | otherwise = "many"
- n_arguments | n == 0 = ppStr "no arguments"
- | n == 1 = ppStr "1 argument"
- | True = ppCat [ppInt n, ppStr "arguments"]
-
-----------------------------------------------------------------
-underAppliedTyErr :: UniType -> SrcLoc -> Error
-underAppliedTyErr ty locn
- = addErrLoc locn "A for-all type has been applied to too few arguments" ( \ sty ->
- ppAboves [
- ppBesides [ppStr "The type is `", ppr sty ty, ppStr "';"],
- ppStr "This might be because of a GHC bug; feel free to report",
- ppStr "it to glasgow-haskell-bugs@dcs.glasgow.ac.uk."])
-
-----------------------------------------------------------------
-unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> Error
-
-unifyErr unify_err_info unify_err_context locn
- = addShortErrLocLine locn ( \ sty ->
- pprUnifyErrInfo sty unify_err_info unify_err_context)
-
-----------------------------------------------------------------
-varyingArgsErr :: Name -> [RenamedMatch] -> Error
- -- Different number of arguments in different equations
-
-varyingArgsErr name matches
- = dontAddErrLoc "Varying number of arguments for function" ( \ sty ->
- ppr sty name )
-{-
-varyingArgsErr name matches
- = addErrLoc locn "Function Definition Error" ( \ sty ->
- ppBesides [ppStr "Function `", ppr sty name, ppStr "' should have a fixed number of arguments" ])
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UnifyErr-types]{@UnifyErrInfo@ and @UnifyErrContext@ datatypes}
-%* *
-%************************************************************************
-
-Here are the things that can go wrong during unification:
-
-\begin{code}
-data UnifyErrInfo
- = UnifyMisMatch UniType UniType
- | TypeRec TyVar TauType -- Occurs check failure
-
- | UnifyListMisMatch [TauType] [TauType] -- Args to unifyList: diff lengths
- -- produces system error
-
- | UnifyUnboxedMisMatch UniType UniType -- No unboxed specialisation
-
-\end{code}
-
-@UnifyErrContext@ gives some context for unification
-errors found in expressions. Also see the @UnifyErrInfo@ type (above),
-as well as the general error-reporting type @Error@ (in @TcErrors@).
-\begin{code}
-data UnifyErrContext
- = PredCtxt RenamedExpr
- | AppCtxt RenamedExpr RenamedExpr
-
- | TooManyArgsCtxt RenamedExpr -- The offending function
- -- We don't want the typechecked expr here,
- -- because that may be full of
- -- confusing dictionaries
-
- | FunAppCtxt RenamedExpr -- The offending function
- (Maybe Id) -- same info (probably) in a more convenient form
- RenamedExpr -- The offending arg
- UniType -- Expected type of offending arg
- UniType -- Inferred type for offending arg
- Int -- Which arg number (first is 1)
-
- | OpAppCtxt RenamedExpr RenamedExpr RenamedExpr
- | SectionLAppCtxt RenamedExpr RenamedExpr
- | SectionRAppCtxt RenamedExpr RenamedExpr
- | CaseCtxt RenamedExpr [RenamedMatch]
- | BranchCtxt RenamedExpr RenamedExpr
- | ListCtxt [RenamedExpr]
- | PatCtxt RenamedPat
- | CaseBranchesCtxt [RenamedMatch]
- | FilterCtxt RenamedExpr
- | GeneratorCtxt RenamedPat RenamedExpr
- | GRHSsBranchCtxt [RenamedGRHS]
- | GRHSsGuardCtxt RenamedExpr
- | PatMonoBindsCtxt RenamedPat RenamedGRHSsAndBinds
- | FunMonoBindsCtxt Name [RenamedMatch]
- | MatchCtxt UniType UniType
- | ArithSeqCtxt RenamedExpr
- | CCallCtxt String [RenamedExpr]
- | AmbigDictCtxt [Inst] -- Occurs check when simplifying ambiguous
- -- dictionaries. Should never happen!
- | SigCtxt Id UniType
- | MethodSigCtxt Name UniType
- | ExprSigCtxt RenamedExpr UniType
- | ValSpecSigCtxt Name UniType SrcLoc
- | ValSpecSpecIdCtxt Name UniType Name SrcLoc
-
- -- The next two contexts are associated only with TcSimplifyAndCheck failures
- | BindSigCtxt [Id] -- Signature(s) for a group of bindings
- | SuperClassSigCtxt -- Superclasses for this instance decl
-
- | CaseBranchCtxt RenamedMatch
- | Rank2ArgCtxt TypecheckedExpr UniType
-#ifdef DPH
- | PodCtxt [RenamedExpr]
- | ParFilterCtxt RenamedExpr
- | DrawnCtxt [RenamedPat] RenamedPat RenamedExpr
- | IndexCtxt [RenamedExpr] RenamedPat RenamedExpr
- | ParPidPatCtxt RenamedPat
- | ParPidExpCtxt RenamedExpr
- | ParZFlhsCtxt RenamedExpr
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Errors-print-unify]{Printing unification error info}
-%* *
-%************************************************************************
-
-\begin{code}
-ppUnifyErr :: Pretty -> Pretty -> Pretty
-ppUnifyErr head rest = ppSep [head, {-if you want a blank line: ppSP,-} rest]
-
-pprUnifyErrInfo sty (UnifyMisMatch mt1 mt2) err_ctxt
- = ppUnifyErr (ppSep [ppBesides [ppStr "Couldn't match the type `", ppr sty mt1, ppStr "'"],
- ppBesides [ppStr "against `", ppr sty mt2, ppStr "'."]])
- (pprUnifyErrContext sty err_ctxt)
-
-pprUnifyErrInfo sty (TypeRec tyvar ty) err_ctxt
- = ppUnifyErr (ppBesides [ppStr "Cannot construct the infinite type `",
- ppr sty tyvar,
- ppStr "' = `",ppr sty ty, ppStr "' (\"occurs check\")."])
- (pprUnifyErrContext sty err_ctxt)
-
-pprUnifyErrInfo sty (UnifyListMisMatch tys1 tys2) err_ctxt
- = panic "pprUnifyErrInfo: unifying lists of types of different lengths"
-
-pprUnifyErrInfo sty (UnifyUnboxedMisMatch mt1 mt2) err_ctxt
- = ppUnifyErr (ppSep [ppBesides [ppStr "Couldn't match the type variable `", ppr sty mt1, ppStr "'"],
- ppBesides [ppStr "against unboxed type `", ppr sty mt2, ppStr "'."],
- ppStr "Try using -fspecialise-unboxed ..." ])
- (pprUnifyErrContext sty err_ctxt)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Errors-print-context]{Printing unification error context}
-%* *
-%************************************************************************
-
-\begin{code}
-pp_nest_hang :: String -> Pretty -> Pretty
-pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
-
-context = "Error detected when type-checking "
-
-ppContext s = ppStr (context ++ s)
-
-pprUnifyErrContext sty (PredCtxt e)
- = ppHang (ppStr "In a predicate expression:") 4 (ppr sty e)
-
-pprUnifyErrContext sty (AppCtxt f a)
- = ppHang (ppStr "In a function application:") 4 (ppr sty (App f a))
-
-pprUnifyErrContext sty (FunAppCtxt f maybe_id actual_arg expected_arg_ty actual_arg_ty n)
- = let
-
- (have_extra_info, f_id, f_type)
- = case maybe_id of
- Nothing -> (False, bottom, bottom)
- Just id -> (True, id, getIdUniType id)
-
- free_tyvars = extractTyVarsFromTy f_type
- bottom = panic "no maybe_id"
- in
- ppAboves [
- ppHang (ppCat [ ppStr "In the", speakNth n, ppStr "argument of",
- ppBesides [ppChar '`', ppr sty f, ppStr "',"] ])
- 4 (ppBesides [ppStr " namely `", ppr sty actual_arg, ppStr "'," ]),
-
- ppHang (ppStr "Expected type of the argument: ")
- 4 (ppr sty expected_arg_ty),
-
- ppHang (ppStr "Inferred type of the argument: ")
- 4 (ppr sty actual_arg_ty),
-
-{- OMIT
- I'm not sure this adds anything
-
- if have_extra_info
- then ppHang (ppCat [ppStr "The type of",
- ppBesides [ppChar '`', ppr sty f_id, ppChar '\''],
- ppStr "is"]) 4
- (ppBesides [ppChar '`', ppr sty f_type, ppStr "'."])
- else ppNil,
--}
-
- if not have_extra_info || null free_tyvars || isSysLocalId f_id
- -- SysLocals are created for the local (monomorphic) versions
- -- of recursive functions, and the monomorphism suggestion
- -- below is sometimes positively misleading. Notably,
- -- if you give an erroneous type sig, you may well end
- -- up with a unification error like this, and it usually ain't due
- -- to monomorphism.
- then ppNil
- else
- ppAboves [
- ppSep [ppStr "Possible cause of error:",
- ppBesides [ppChar '`', ppr sty f, ppChar '\''],
- ppStr "is not polymorphic"],
- ppSep [ppStr "it is monomorphic in the type variable(s):",
- interpp'SP sty free_tyvars]
- ]
- ]
-
-pprUnifyErrContext sty (TooManyArgsCtxt f)
- = ppHang (ppStr "Too many arguments in an application of the function")
- 4 (ppBesides [ ppChar '`', ppr sty f, ppStr "'." ])
-
-pprUnifyErrContext sty (SectionLAppCtxt expr op)
- = ppHang (ppStr "In a left section:") 4 (ppr sty (SectionL expr op))
-
-pprUnifyErrContext sty (SectionRAppCtxt op expr)
- = ppHang (ppStr "In a right section:") 4 (ppr sty (SectionR op expr))
-
-pprUnifyErrContext sty (OpAppCtxt a1 op a2)
- = ppHang (ppStr "In an infix-operator application:") 4 (ppr sty (OpApp a1 op a2))
-
-pprUnifyErrContext sty (CaseCtxt e as)
- = ppHang (ppStr "In a case expression:") 4 (ppr sty (Case e as))
-
-pprUnifyErrContext sty (BranchCtxt b1 b2)
- = ppSep [ppStr "In the branches of a conditional:",
- pp_nest_hang "`then' branch:" (ppr sty b1),
- pp_nest_hang "`else' branch:" (ppr sty b2)]
-
-pprUnifyErrContext sty (ListCtxt es)
- = ppHang (ppStr "In a list expression:") 4 (
- ppBesides [ppLbrack, interpp'SP sty es, ppRbrack])
-
-pprUnifyErrContext sty (PatCtxt (ConPatIn name pats))
- = ppHang (ppStr "In a constructed pattern:")
- 4 (ppCat [ppr sty name, interppSP sty pats])
-
-pprUnifyErrContext sty (PatCtxt (ConOpPatIn pat1 op pat2))
- = ppHang (ppStr "In an infix-operator pattern:")
- 4 (ppCat [ppr sty pat1, ppr sty op, ppr sty pat2])
-
-pprUnifyErrContext sty (PatCtxt (ListPatIn ps))
- = ppHang (ppStr "In an explicit list pattern:")
- 4 (ppBesides [ppLbrack, interpp'SP sty ps, ppRbrack])
-
-pprUnifyErrContext sty (PatCtxt pat@(AsPatIn _ _))
- = ppHang (ppStr "In an as-pattern:") 4 (ppr sty pat)
-
-pprUnifyErrContext sty (CaseBranchesCtxt (m:ms))
- = ppAboves [ppStr "Inside two case alternatives:",
- ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) [m])),
- ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) ms))]
-
-pprUnifyErrContext sty (FilterCtxt e)
- = ppHang (ppStr "In a guard in a list-comprehension:") 4 (ppr sty e)
-
-pprUnifyErrContext sty (GeneratorCtxt p e)
- = ppHang (ppStr "In a generator in a list-comprehension:")
- 4 (ppSep [ppr sty p, ppStr "<-", ppr sty e])
-
-pprUnifyErrContext sty (GRHSsBranchCtxt grhss)
- = ppAboves [ppStr "In some guarded right-hand-sides:",
- ppNest 4 (ppAboves (map (pprGRHS sty False) grhss))]
-
-pprUnifyErrContext sty (GRHSsGuardCtxt g)
- = ppHang (ppStr "In a guard on an equation:") 4 (ppr sty g)
-
-pprUnifyErrContext sty (PatMonoBindsCtxt pat grhss_and_binds)
- = ppHang (ppStr "In a pattern binding:")
- 4 (ppr sty (PatMonoBind pat grhss_and_binds mkUnknownSrcLoc))
-
-pprUnifyErrContext sty (FunMonoBindsCtxt id matches)
- = ppHang (ppStr "When combining a function's equation(s) & type signature (if applicable):")
- 4 (ppBesides [ppr sty id, ppSP, pprMatches sty (False,ppNil) matches])
-
-pprUnifyErrContext sty (CaseBranchCtxt match)
- = ppHang (ppStr "When combining a \"case\" branch & type signature (if applicable):")
- 4 (pprMatch sty True{-is_case-} match)
-
-pprUnifyErrContext sty (MatchCtxt ty1 ty2)
- = ppAboves [ppStr "In a type signature:",
- pp_nest_hang "Signature:" (ppr sty ty1),
- pp_nest_hang "Inferred type:" (ppr sty ty2)]
-
-pprUnifyErrContext sty (ArithSeqCtxt expr)
- = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
-
-pprUnifyErrContext sty (CCallCtxt label args)
- = ppAboves [ppStr "In a _ccall_ or _casm_:",
- pp_nest_hang "C-calling magic:" (ppStr label),
- pp_nest_hang "Arguments:" (ppInterleave ppComma (map (ppr sty) args))]
-
--- OLD: kill
-pprUnifyErrContext sty (AmbigDictCtxt dicts)
- = ppStr "Ambiguous dictionary occurs check: should never happen!"
-
-pprUnifyErrContext sty (SigCtxt id tau_ty)
- = ppHang (ppBesides [ppStr "In the type signature for ",
- ppr sty id,
- ppStr ":"]
- ) 4 (ppr sty tau_ty)
-
-pprUnifyErrContext sty (MethodSigCtxt name ty)
- = ppHang (ppBesides [ ppStr "When matching the definition of class method `",
- ppr sty name, ppStr "' to its signature :" ]
- ) 4 (ppr sty ty)
-
-pprUnifyErrContext sty (ExprSigCtxt expr ty)
- = ppHang (ppStr "In an expression with a type signature:")
- 4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"),
- ppr sty ty])
-
-pprUnifyErrContext sty (BindSigCtxt ids)
- = ppHang (ppStr "When checking type signatures for: ")
- 4 (ppInterleave (ppStr ", ") (map (ppr sty) ids))
-
-pprUnifyErrContext sty SuperClassSigCtxt
- = ppStr "When checking superclass constraints on instance declaration"
-
-pprUnifyErrContext sty (Rank2ArgCtxt expr ty)
- = ppHang (ppStr "In an argument which has rank-2 polymorphic type:")
- 4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"),
- ppr sty ty])
-
-pprUnifyErrContext sty (ValSpecSigCtxt v ty src_loc)
- = ppHang (ppStr "In a SPECIALIZE pragma for a value:")
- 4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"),
- ppr sty ty])
-
-pprUnifyErrContext sty (ValSpecSpecIdCtxt v ty spec src_loc)
- = ppHang (ppStr "When checking type of explicit id in SPECIALIZE pragma:")
- 4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"),
- ppr sty ty,
- ppBeside (ppStr " = ") (ppr sty spec)])
-
-#ifdef DPH
-pprUnifyErrContext sty (PodCtxt es)
- = ppAboves [ppStr "In a POD expression:",
- ppBesides [ppStr "<<", interpp'SP sty es, ppStr ">>"]]
-
-pprUnifyErrContext sty (ParFilterCtxt e)
- = ppHang (ppStr "In a guard of a POD comprehension:") 4
- (ppr sty e)
-
-pprUnifyErrContext sty (DrawnCtxt ps p e)
- = ppHang (ppStr "In parallel drawn from generator:")
- 4 (ppSep [ppStr "(|" ,interpp'SP sty ps, ppStr ";" ,
- ppr sty p ,ppStr "|)", ppStr "<<-", ppr sty e])
-
-pprUnifyErrContext sty (IndexCtxt es p e)
- = ppHang (ppStr "In parallel index from generator:")
- 4 (ppSep [ppStr "(|",interpp'SP sty es, ppStr ";" ,
- ppr sty p ,ppStr "|)" , ppStr "<<=", ppr sty e])
-
-pprUnifyErrContext sty (ParPidPatCtxt p)
- = ppHang (ppStr "In pattern for processor ID has to be in class Pid:")
- 4 (ppr sty p)
-
-pprUnifyErrContext sty (ParPidExpCtxt e)
- = ppHang (ppStr "In expression for processor ID has to be in class Pid:")
- 4 (ppr sty e)
-
-pprUnifyErrContext sty (ParZFlhsCtxt e)
- = ppHang (ppStr "In LHS of a POD comprehension has to be in class Processor")
- 4 (ppr sty e)
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DPH
-pprPodizedWarning :: PodWarning -> Error
-pprPodizedWarning (EntryNotPodized b)
- = addWarningLoc (getSrcLoc b) (\ sty ->
- ppBeside (ppStr "Unable to parallelise entry: ")
- (ppr sty b)
- )
-
-pprPodizedWarning (NoGoNestedPodized b)
- = addWarningLoc (getSrcLoc b) (\ sty ->
- ppBeside (ppStr "Sorry no nested parallelism yet: ")
- (ppr sty b)
- )
-
-pprPodizedWarning (ContextNotAvailable b c)
- = addWarningLoc (getSrcLoc b) (\ sty ->
- ppAbove (ppBesides [ppStr "No parallelisation of binding for a ",
- ppStr (show_context c) , ppStr ": ",ppr sty b])
- (ppBesides [ppStr "Maybe you should re-compile this module ",
- ppStr "with the `",ppStr (which_flag c),
- ppStr "' flag."])
- )
-
-pprPodizedWarning (ImportNotAvailable b c)
- = addWarningLoc (getSrcLoc b) (\ sty ->
- ppAboves [ppBesides [ppStr "No parallelisation of binding for a ",
- ppStr (show_context c),ppStr ": ", ppr sty b],
- ppBesides [ppStr "If you re-compile the module `",
- ppStr (fst (getOrigName b)), ppStr "`"],
- ppBesides [ppStr "with the `",ppStr (which_flag c),
- ppStr "' flag I may do a better job :-)"]]
- )
-
-
-pprPodizedWarning (ArgsInDifferentContexts b)
- = addWarningLoc (getSrcLoc b) (\ sty ->
- ppBesides [ppStr "Higher Order argument used in different ",
- ppStr "parallel contexts : ",ppr sty b]
- )
-
-pprPodizedWarning (NoPodization)
- = addWarning (\ sty ->
- ppStr "Program not podized")
-
-pprPodizedWarning (PodizeStats ci pi vl pl)
- = addWarning (\ sty ->
- (ppHang (ppStr "Podization Statistics:")
- 5
- (ppAboves [ppCat [ppStr "Info collecting passes =",ppr sty ci],
- ppCat [ppStr "Podization passes =",ppr sty pi],
- ppCat [ppStr "Vanilla's deleted =",ppr sty vl],
- ppCat [ppStr "Podized deleted =",ppr sty pl]]))
- )
-
-show_context :: Int -> String
-show_context 1 = "\"vector\""
-show_context 2 = "\"matrix\""
-show_context 3 = "\"cube\""
-show_context n = "\""++(show n)++"-D Pod\""
-
-which_flag :: Int -> String
-which_flag 1 = "-fpodize-vector"
-which_flag 2 = "-fpodize-matrix"
-which_flag 3 = "-fpodize-cube"
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-
-@speakNth@ converts an integer to a verbal index; eg 1 maps to ``first'' etc.
-\begin{code}
-speakNth :: Int -> Pretty
-speakNth 1 = ppStr "first"
-speakNth 2 = ppStr "second"
-speakNth 3 = ppStr "third"
-speakNth 4 = ppStr "fourth"
-speakNth 5 = ppStr "fifth"
-speakNth 6 = ppStr "sixth"
-speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ]
- where
- st_nd_rd_th | n_rem_10 == 1 = "st"
- | n_rem_10 == 2 = "nd"
- | n_rem_10 == 3 = "rd"
- | otherwise = "th"
-
- n_rem_10 = n `rem` 10
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Main where
-mainPrimIO :: _State _RealWorld -> ((), _State _RealWorld)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
\begin{code}
#include "HsVersions.h"
-module Main (
-#ifdef __GLASGOW_HASKELL__
- mainPrimIO
-#else
- main
-#endif
- ) where
+module Main ( main ) where
+
+import Ubiq{-uitous-}
+
+import PreludeGlaST ( thenPrimIO, _FILE{-instances-} ) -- ToDo: STOP using this...
import MainMonad
+import HsSyn
+
+import ReadPrefix ( rdModule )
+import Rename ( renameModule )
+import Typecheck ( typecheckModule, InstInfo )
+import Desugar ( deSugar, DsMatchContext, pprDsWarnings )
+
+import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
+import ErrUtils ( pprBagOfErrors )
+import Maybes ( MaybeErr(..) )
+import PrelInfo ( builtinNameInfo )
+import RdrHsSyn ( getRawExportees )
-import AbsCSyn
-import AbsPrel ( builtinNameInfo )
-import AbsSyn
-import AbsUniType ( isDataTyCon, TauType(..), UniType, TyVar, TyCon, Class )
-import Bag ( emptyBag, isEmptyBag, Bag )
-import CE ( CE(..), UniqFM )
-import CodeGen ( codeGen )
-import CoreToStg ( topCoreBindsToStg )
-import Desugar ( deSugar )
-import DsMonad ( DsMatchContext, DsMatchKind, pprDsWarnings )
-import E ( getE_TCE, E, GVE(..) )
- -- most of above needed by mkInterface
-#ifndef DPH
-import Errors ( pprBagOfErrors, Error(..) )
-#else
-import Errors ( pprBagOfErrors, pprPodizedWarning, Error(..) )
-#endif {- Data Parallel Haskell -}
-import Id ( mkInstId, Id, Inst )
-import Maybes ( maybeToBool, Maybe(..), MaybeErr(..) )
-import MkIface ( mkInterface )
-import Outputable
-import PlainCore ( CoreExpr, CoreBinding, pprPlainCoreBinding,
- PlainCoreProgram(..), PlainCoreBinding(..)
- )
+import PprCore ( pprPlainCoreBinding )
+import PprStyle ( PprStyle(..) )
import Pretty
-#ifdef USE_NEW_READER
-import ReadPrefix2 ( rdModule )
-#else
-import {-hide from mkdependHS-}
- ReadPrefix ( rdModule )
-#endif
-import Rename -- renameModule ...
-import SimplCore -- core2core
-import SimplStg ( stg2stg )
---ANDY: import SimplHaskell
-import StgSyn ( pprPlainStgBinding, StgBinding, StgRhs, CostCentre,
- StgBinderInfo, PlainStgProgram(..), PlainStgBinding(..)
+import Id ( GenId ) -- instances
+import Name ( Name ) -- instances
+import ProtoName ( ProtoName ) -- instances
+import PprType ( GenType, GenTyVar ) -- instances
+import TyVar ( GenTyVar ) -- instances
+import Unique ( Unique) -- instances
+
+{-
+--import AbsCSyn
+--import CodeGen ( codeGen )
+--import CoreToStg ( topCoreBindsToStg )
+--import MkIface ( mkInterface )
+
+--import SimplCore ( core2core )
+--import SimplStg ( stg2stg )
+--import StgSyn ( pprPlainStgBinding, GenStgBinding, GenStgRhs, CostCentre,
+ StgBinderInfo, StgBinding(..)
)
-import TCE ( rngTCE, {- UNUSED: printTypeInfoForPop,-} TCE(..)
- IF_ATTACK_PRAGMAS(COMMA eltsUFM)
- )
-import Typecheck -- typecheckModule ...
-import SplitUniq
-import Unique -- lots of UniqueSupplies, etc.
-import Util
#if ! OMIT_NATIVE_CODEGEN
-import AsmCodeGen ( dumpRealAsm
-# if __GLASGOW_HASKELL__
- , writeRealAsm
-# endif
- )
+--import AsmCodeGen ( dumpRealAsm, writeRealAsm )
#endif
+-}
-#ifdef USE_SEMANTIQUE_STRANAL
-import ProgEnv ( ProgEnv(..), TreeProgEnv(..), createProgEnv )
-import StrAnal ( ppShowStrAnal, OAT )
-#endif
-#ifdef DPH
-import PodizeCore ( podizeCore , PodWarning)
-import AbsCTopApal ( nuAbsCToApal )
-import NextUsed ( pprTopNextUsedC, getTopLevelNexts, AbsCNextUsed,
- TopAbsCNextUsed(..) , MagicId)
-
-#endif {- Data Parallel Haskell -}
\end{code}
\begin{code}
-#ifndef __GLASGOW_HASKELL__
-main :: Dialogue
-
-main = mainIOtoDialogue main_io
-
-main_io :: MainIO ()
-main_io
-#else
-mainPrimIO
-#endif
- = BSCC("mainIO")
- BSCC("rdInput") readMn stdin ESCC `thenMn` \ input_pgm ->
- getArgsMn `thenMn` \ raw_cmd_line ->
- classifyOpts raw_cmd_line `thenMn` \ cmd_line_info ->
- BSCC("doPasses")
+main
+ = readMn stdin `thenMn` \ input_pgm ->
+ let
+ cmd_line_info = classifyOpts
+ in
doIt cmd_line_info input_pgm
- ESCC ESCC
\end{code}
\begin{code}
-doIt :: CmdLineInfo -> String -> MainIO ()
-#ifndef DPH
-doIt (switch_lookup_fn, core_cmds, stg_cmds) input_pgm
-#else
-doIt (switch_lookup_fn, core_cmds, podize_cmds, pcore_cmds, stg_cmds) input_pgm
-#endif {- Data Parallel Haskell -}
- --
- -- Help functions and boring global variables (e.g., printing style)
- -- are figured out first; the "business end" follows, in the
- -- body of the let.
- --
- = let
- -- ****** help functions:
-
- switch_is_on switch = switchIsOn switch_lookup_fn switch
-
- string_switch_is_on switch
- = maybeToBool (stringSwitchSet switch_lookup_fn switch)
-
- show_pass
- = if switch_is_on D_show_passes
- then \ what -> writeMn stderr ("*** "++what++":\n")
- else \ what -> returnMn ()
-
- doOutput switch io_action
- = BSCC("doOutput")
- case (stringSwitchSet switch_lookup_fn switch) of
- Nothing -> returnMn ()
- Just fname ->
- fopen fname "a+" `thenMn` \ file ->
- if (file == ``NULL'') then
- error ("doOutput: failed to open:"++fname)
- else
- io_action file `thenMn` \ () ->
- fclose file `thenMn` \ status ->
- if status == 0
- then returnMn ()
- else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
- ESCC
-
- doDump switch hdr string
- = BSCC("doDump")
- if (switch_is_on switch)
- then writeMn stderr hdr `thenMn_`
- writeMn stderr ('\n': string) `thenMn_`
- writeMn stderr "\n"
- else returnMn ()
- ESCC
-
- -- ****** printing styles and column width:
-
- pprCols = (80 :: Int) -- could make configurable
-
- (pprStyle, pprErrorsStyle)
- = if switch_is_on PprStyle_All then
- (PprShowAll, PprShowAll)
- else if switch_is_on PprStyle_Debug then
- (PprDebug, PprDebug)
- else if switch_is_on PprStyle_User then
- (PprForUser, PprForUser)
- else -- defaults...
- (PprDebug, PprForUser)
-
- pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
- in
- -- non-tuple-ish bindings...
-
- -- ****** possibly fiddle builtin namespaces:
-
- BIND (BSCC("builtinEnv")
- builtinNameInfo switch_is_on {-switch looker-upper-}
- ESCC
- )
- _TO_ (init_val_lookup_fn, init_tc_lookup_fn) ->
-
- -- **********************************************
- -- Welcome to the business end of the main module
- -- of the Glorious Glasgow Haskell compiler!
- -- **********************************************
-#ifndef DPH
- doDump Verbose "Glasgow Haskell Compiler, version 0.27" "" `thenMn_`
-#else
- doDump Verbose "Data Parallel Haskell Compiler, version 0.06 (Glasgow 0.27)" ""
- `thenMn_`
-#endif {- Data Parallel Haskell -}
+doIt :: ([CoreToDo], [StgToDo]) -> String -> MainIO ()
+
+doIt (core_cmds, stg_cmds) input_pgm
+ = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.3-xx" ""
+ `thenMn_`
-- ******* READER
- show_pass "Read" `thenMn_`
-#ifdef USE_NEW_READER
- BSCC("rdModule")
- rdModule
- ESCC
- `thenMn` \ (mod_name, export_list_fns, absyn_tree) ->
-
- BIND (\x -> x) _TO_ bar_foo ->
- -- so BINDs and BENDs add up...
-#else
- BIND BSCC("rdModule")
- rdModule input_pgm
- ESCC
- _TO_ (mod_name, export_list_fns, absyn_tree) ->
-#endif
+ show_pass "Reader" `thenMn_`
+ rdModule `thenMn`
+
+ \ (mod_name, export_list_fns, absyn_tree) ->
+
let
- -- reader things used (much?) later
+ -- reader things used much later
ds_mod_name = mod_name
if_mod_name = mod_name
co_mod_name = mod_name
st_mod_name = mod_name
cc_mod_name = mod_name
- -- also: export_list_fns
in
- doDump D_source_stats "\nSource Statistics:"
- (pp_show (ppSourceStats absyn_tree)) `thenMn_`
+ doDump opt_D_dump_rdr "Reader:"
+ (pp_show (ppr pprStyle absyn_tree)) `thenMn_`
- doDump D_dump_rif2hs "Parsed, Haskellised:"
- (pp_show (ppr pprStyle absyn_tree)) `thenMn_`
+ doDump opt_D_source_stats "\nSource Statistics:"
+ (pp_show (ppSourceStats absyn_tree)) `thenMn_`
- -- UniqueSupplies for later use
+ -- UniqueSupplies for later use (these are the only lower case uniques)
getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer
getSplitUniqSupplyMn 't' `thenMn` \ tc_uniqs -> -- typechecker
getSplitUniqSupplyMn 'd' `thenMn` \ ds_uniqs -> -- desugarer
getSplitUniqSupplyMn 's' `thenMn` \ sm_uniqs -> -- core-to-core simplifier
- getSplitUniqSupplyMn 'C' `thenMn` \ c2s_uniqs -> -- core-to-stg
- getSplitUniqSupplyMn 'T' `thenMn` \ st_uniqs -> -- stg-to-stg passes
- getSplitUniqSupplyMn 'F' `thenMn` \ fl_uniqs -> -- absC flattener
- getSplitUniqSupplyMn 'P' `thenMn` \ prof_uniqs -> -- profiling tidy-upper
- getSplitUniqSupplyMn 'L' `thenMn` \ pre_ncg_uniqs -> -- native-code generator
- let
- ncg_uniqs = {-mkUniqueSupplyGrimily-} pre_ncg_uniqs
- in
+ getSplitUniqSupplyMn 'c' `thenMn` \ c2s_uniqs -> -- core-to-stg
+ getSplitUniqSupplyMn 'g' `thenMn` \ st_uniqs -> -- stg-to-stg passes
+ getSplitUniqSupplyMn 'f' `thenMn` \ fl_uniqs -> -- absC flattener
+ getSplitUniqSupplyMn 'n' `thenMn` \ ncg_uniqs -> -- native-code generator
+
-- ******* RENAMER
- show_pass "Rename" `thenMn_`
- BIND BSCC("Renamer")
- renameModule switch_is_on
- (init_val_lookup_fn, init_tc_lookup_fn)
- absyn_tree
- rn_uniqs
- ESCC
- _TO_ (mod4, import_names, final_name_funs, rn_errs_bag) ->
+ show_pass "Renamer" `thenMn_`
+
+ case builtinNameInfo
+ of { (init_val_lookup_fn, init_tc_lookup_fn) ->
+
+ case (renameModule (init_val_lookup_fn, init_tc_lookup_fn)
+ absyn_tree
+ rn_uniqs)
+ of { (mod4, import_names, final_name_funs, rn_errs_bag) ->
let
- -- renamer things used (much?) later
+ -- renamer things used much later
cc_import_names = import_names
in
- doDump D_dump_rn4 "Renamer-pass4:"
- (pp_show (ppr pprStyle mod4)) `thenMn_`
-
if (not (isEmptyBag rn_errs_bag)) then
- -- Stop right here
writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
`thenMn_` writeMn stderr "\n"
`thenMn_` exitMn 1
- else -- No renaming errors, carry on with...
+ else -- No renaming errors ...
+
+ doDump opt_D_dump_rn "Renamer:"
+ (pp_show (ppr pprStyle mod4)) `thenMn_`
-- ******* TYPECHECKER
- show_pass "TypeCheck" `thenMn_`
- BIND (case BSCC("TypeChecker")
- typecheckModule switch_is_on tc_uniqs final_name_funs mod4
- ESCC
- of
- Succeeded stuff
- -> (emptyBag, stuff)
- Failed tc_errs_bag
- -> (tc_errs_bag,
- panic "main: tickled tc_results even though there were errors"))
-
- _TO_ (tc_errs_bag, tc_results) ->
+ show_pass "TypeCheck" `thenMn_`
+ case (case (typecheckModule tc_uniqs final_name_funs mod4) of
+ Succeeded (stuff, warns)
+ -> (emptyBag, warns, stuff)
+ Failed (errs, warns)
+ -> (errs, warns, error "tc_results"))
+
+ of { (tc_errs_bag, tc_warns_bag, tc_results) ->
+
+ (if (isEmptyBag tc_warns_bag) then
+ returnMn ()
+ else
+ writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
+ `thenMn_` writeMn stderr "\n"
+ ) `thenMn_`
- let
- ppr_b :: (Inst, TypecheckedExpr) -> Pretty
- ppr_b (i,e) = ppr pprStyle (VarMonoBind (mkInstId i) e)
- in
if (not (isEmptyBag tc_errs_bag)) then
- -- Must stop *before* trying to dump tc output, because
- -- if it fails it does not give you any useful stuff back!
writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
`thenMn_` writeMn stderr "\n"
`thenMn_` exitMn 1
- else ( -- No typechecking errors either -- so, go for broke!
+ else ( -- No typechecking errors ...
- BIND tc_results
- _TO_ (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
+ case tc_results
+ of { (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
interface_stuff@(_,_,_,_,_), -- @-pat just for strictness...
- pragma_tycon_specs, {-UNUSED:big_env,-} this_mod_env, ddump_deriv) ->
- let
--- big_tce = getE_TCE big_env
--- big_elts = rngTCE big_tce
-
- this_mod_tce = getE_TCE this_mod_env
- this_mod_elts = rngTCE this_mod_tce
-
- local_tycons = [tc | tc <- this_mod_elts,
- isLocallyDefined tc, -- from this module only
- isDataTyCon tc ] -- algebraic types only
- in
--- pprTrace "Envs:" (ppAboves [
--- ppr pprStyle if_global_ids,
--- ppr pprStyle if_tce,
--- ppr pprStyle if_ce,
--- ppr pprStyle this_mod_env,
--- ppr pprStyle big_env
--- ]) (
-
- doDump D_dump_tc "Typechecked:"
- (pp_show
- (ppAboves [ppr pprStyle class_binds,
- ppr pprStyle inst_binds,
- ppAboves (map ppr_b const_binds),
- ppr pprStyle val_binds])) `thenMn_`
-
- doDump D_dump_deriv "Derived instances:"
- (pp_show (ddump_deriv pprStyle)) `thenMn_`
-
---NOT REALLY USED:
--- doDump D_dump_type_info "" (pp_show (printTypeInfoForPop big_tce)) `thenMn_`
+ (local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) ->
+
+ doDump opt_D_dump_tc "Typechecked:"
+ (pp_show (ppAboves [
+ ppr pprStyle class_binds,
+ ppr pprStyle inst_binds,
+ ppAboves (map (\ (i,e) -> ppr pprStyle (VarMonoBind i e)) const_binds),
+ ppr pprStyle val_binds])) `thenMn_`
+
+ doDump opt_D_dump_deriv "Derived instances:"
+ (pp_show (ddump_deriv pprStyle)) `thenMn_`
+
+
-- ******* DESUGARER
- show_pass "DeSugar" `thenMn_`
+ show_pass "DeSugar" `thenMn_`
let
(desugared,ds_warnings)
- = BSCC("DeSugarer")
- deSugar ds_uniqs switch_lookup_fn ds_mod_name typechecked_quad
- ESCC
+ = deSugar ds_uniqs ds_mod_name typechecked_quad
in
(if isEmptyBag ds_warnings then
returnMn ()
else
writeMn stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings))
`thenMn_` writeMn stderr "\n"
- ) `thenMn_`
+ ) `thenMn_`
+
+ doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves
+ (map (pprPlainCoreBinding pprStyle) desugared)))
+ `thenMn_`
- doDump D_dump_ds "Desugared:" (pp_show (ppAboves
- (map (pprPlainCoreBinding pprStyle) desugared))) `thenMn_`
+{- LATER ...
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
core2core core_cmds switch_lookup_fn co_mod_name pprStyle
sm_uniqs local_tycons pragma_tycon_specs desugared
- `thenMn` \ (simplified, inlinings_env,
- SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
+ `thenMn`
- doDump D_dump_simpl "Simplified:" (pp_show (ppAboves
- (map (pprPlainCoreBinding pprStyle) simplified))) `thenMn_`
+ \ (simplified, inlinings_env,
+ SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
--- ANDY:
--- doDump D_dump_core_passes_info "(Haskell) Simplified:"
--- (coreToHaskell simplified) `thenMn_`
-
-#ifdef DPH
- -- ******* PODIZE (VECTORIZE) THE CORE PROGRAM
- let
- (warn,podized) = BSCC("PodizeCore")
- podizeCore podize_cmds switch_is_on
- uniqSupply_p simplified
- ESCC
- in
- (if (not (null warn))
- then writeMn stderr "\n" `thenMn_`
- writeMn stderr (ppShow pprCols (ppAboves
- (map (\w -> pprPodizedWarning w pprErrorsStyle) warn))) `thenMn_`
- writeMn stderr "\n"
- else returnMn ()) `thenMn_`
-
- doDump D_dump_pod "Podization:" (pp_show (ppAboves
- (map (pprPlainCoreBinding pprStyle) podized))) `thenMn_`
-
- -- ******** CORE-TO-CORE SIMPLIFICATION OF PODIZED PROGRAM
- let
- psimplified = BSCC("PodizeCore2Core")
- core2core pcore_cmds switch_is_on pprStyle
- uniqSupply_S podized
- ESCC
- in
- doDump D_dump_psimpl "Par Simplified:" (pp_show (ppAboves
- (map (pprPlainCoreBinding pprStyle) psimplified))) `thenMn_`
-
-#endif {- Data Parallel Haskell -}
-
-#ifdef USE_SEMANTIQUE_STRANAL
- -- ******* SEMANTIQUE STRICTNESS ANALYSER
- doDump D_dump_stranal_sem "Strictness:" (ppShowStrAnal simplified big_env) `thenMn_`
-#endif
+ doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves
+ (map (pprPlainCoreBinding pprStyle) simplified)))
+ `thenMn_`
-- ******* STG-TO-STG SIMPLIFICATION
- show_pass "Core2Stg" `thenMn_`
+ show_pass "Core2Stg" `thenMn_`
let
-#ifndef DPH
- stg_binds = BSCC("Core2Stg")
- topCoreBindsToStg c2s_uniqs simplified
- ESCC
-#else
- stg_binds = BSCC("Core2Stg")
- topCoreBindsToStg c2s_uniqs psimplified
- ESCC
-#endif {- Data Parallel Haskell -}
+ stg_binds = topCoreBindsToStg c2s_uniqs simplified
in
- show_pass "Stg2Stg" `thenMn_`
+
+ show_pass "Stg2Stg" `thenMn_`
stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds
- `thenMn` \ (stg_binds2, cost_centre_info) ->
+ `thenMn`
- doDump D_dump_stg "STG syntax:" (pp_show (ppAboves
- (map (pprPlainStgBinding pprStyle) stg_binds2))) `thenMn_`
+ \ (stg_binds2, cost_centre_info) ->
+
+ doDump opt_D_dump_stg "STG syntax:"
+ (pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2)))
+ `thenMn_`
-- ******* INTERFACE GENERATION (needs STG output)
{- let
if_inst_info = emptyBag
in
-}
- show_pass "Interface" `thenMn_`
+ show_pass "Interface" `thenMn_`
let
mod_interface
- = BSCC("MkInterface")
- mkInterface switch_is_on if_mod_name export_list_fns
+ = mkInterface switch_is_on if_mod_name export_list_fns
inlinings_env all_tycon_specs
interface_stuff
stg_binds2
- ESCC
in
- doOutput ProduceHi BSCC("PrintInterface")
- ( \ file ->
- ppAppendFile file 1000{-pprCols-} mod_interface )
- ESCC `thenMn_`
+ doOutput ProduceHi ( \ file ->
+ ppAppendFile file 1000{-pprCols-} mod_interface )
+ `thenMn_`
-- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
- show_pass "CodeGen" `thenMn_`
+ show_pass "CodeGen" `thenMn_`
let
- abstractC = BSCC("CodeGen")
- codeGen cc_mod_name -- module name for CC labelling
+ abstractC = codeGen cc_mod_name -- module name for CC labelling
cost_centre_info
cc_import_names -- import names for CC registering
switch_lookup_fn
gen_tycons -- type constructors generated locally
all_tycon_specs -- tycon specialisations
stg_binds2
- ESCC
- flat_abstractC = BSCC("FlattenAbsC")
- flattenAbsC fl_uniqs abstractC
- ESCC
+ flat_abstractC = flattenAbsC fl_uniqs abstractC
in
- doDump D_dump_absC "Abstract C:" (dumpRealC switch_is_on abstractC) `thenMn_`
+ doDump opt_D_dump_absC "Abstract C:"
+ (dumpRealC switch_is_on abstractC) `thenMn_`
- doDump D_dump_flatC "Flat Abstract C:" (dumpRealC switch_is_on flat_abstractC) `thenMn_`
+ doDump opt_D_dump_flatC "Flat Abstract C:"
+ (dumpRealC switch_is_on flat_abstractC) `thenMn_`
-- You can have C (c_output) or assembly-language (ncg_output),
-- but not both. [Allowing for both gives a space leak on
(False, False) -> (AbsCNop, AbsCNop)
(True, True) -> error "ERROR: Can't do both .hc and .s at the same time"
- c_output_d = BSCC("PrintRealC")
- dumpRealC switch_is_on flat_absC_c
- ESCC
-
-#ifdef __GLASGOW_HASKELL__
- c_output_w = BSCC("PrintRealC")
- (\ f -> writeRealC switch_is_on f flat_absC_c)
- ESCC
-#else
- c_output_w = c_output_d
-#endif
+ c_output_d = dumpRealC switch_is_on flat_absC_c
+ c_output_w = (\ f -> writeRealC switch_is_on f flat_absC_c)
#if OMIT_NATIVE_CODEGEN
- ncg_output_d
- = error "*** GHC not built with a native-code generator ***"
+ ncg_output_d = error "*** GHC not built with a native-code generator ***"
ncg_output_w = ncg_output_d
#else
- ncg_output_d = BSCC("nativeCode")
- dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs
- ESCC
-
-#ifdef __GLASGOW_HASKELL__
- ncg_output_w = BSCC("nativeCode")
- (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs)
- ESCC
-#else
- ncg_output_w = ncg_output_d
-#endif
+ ncg_output_d = dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs
+ ncg_output_w = (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs)
#endif
in
- doDump D_dump_asm "" ncg_output_d `thenMn_`
- doOutput ProduceS ncg_output_w `thenMn_`
-#ifndef DPH
- -- ********* GHC Finished !!!!
- doDump D_dump_realC "" c_output_d `thenMn_`
- doOutput ProduceC c_output_w `thenMn_`
+ doDump opt_D_dump_asm "" ncg_output_d `thenMn_`
+ doOutput ProduceS ncg_output_w `thenMn_`
-#else
- -- ********* DPH needs native code generator, nearly finished.....
- let
- next_used_flatC = getTopLevelNexts flat_abstractC []
- apal_module = nuAbsCToApal uniqSupply_L mod_name next_used_flatC
- in
- doDump D_dump_nextC "Next Used annotated C:" (ppShow pprCols
- (pprTopNextUsedC next_used_flatC)) `thenMn_`
- doOutput ProduceC ("! /* DAP assembler (APAL): */\n"++apal_module) `thenMn_`
+ doDump opt_D_dump_realC "" c_output_d `thenMn_`
+ doOutput ProduceC c_output_w `thenMn_`
-#endif {- Data Parallel Haskell -}
+LATER -}
exitMn 0
- {-)-} BEND ) BEND BEND BEND BEND
-
-
-ppSourceStats (Module name exports imports fixities typedecls typesigs
+ } ) } } }
+ where
+ -------------------------------------------------------------
+ -- ****** printing styles and column width:
+
+ pprCols = (80 :: Int) -- could make configurable
+
+ (pprStyle, pprErrorsStyle)
+ = if opt_PprStyle_All then
+ (PprShowAll, PprShowAll)
+ else if opt_PprStyle_Debug then
+ (PprDebug, PprDebug)
+ else if opt_PprStyle_User then
+ (PprForUser, PprForUser)
+ else -- defaults...
+ (PprDebug, PprForUser)
+
+ pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
+
+ -------------------------------------------------------------
+ -- ****** help functions:
+
+ show_pass
+ = if opt_D_show_passes
+ then \ what -> writeMn stderr ("*** "++what++":\n")
+ else \ what -> returnMn ()
+
+ doOutput switch io_action
+ = case switch of
+ Nothing -> returnMn ()
+ Just fname ->
+ fopen fname "a+" `thenPrimIO` \ file ->
+ if (file == ``NULL'') then
+ error ("doOutput: failed to open:"++fname)
+ else
+ io_action file `thenMn` \ () ->
+ fclose file `thenPrimIO` \ status ->
+ if status == 0
+ then returnMn ()
+ else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
+
+ doDump switch hdr string
+ = if switch
+ then writeMn stderr hdr `thenMn_`
+ writeMn stderr ('\n': string) `thenMn_`
+ writeMn stderr "\n"
+ else returnMn ()
+
+
+ppSourceStats (HsModule name exports imports fixities typedecls typesigs
classdecls instdecls instsigs defdecls binds
[{-no sigs-}] src_loc)
= ppAboves (map pp_val
[("ExportAll ", export_all), -- 1 if no export list
("ExportDecls ", export_ds),
("ExportModules ", export_ms),
- ("ImportAll ", import_all),
- ("ImportPartial ", import_partial),
- (" PartialDecls ", partial_decls),
- ("ImportHiding ", import_hiding),
- (" HidingDecls ", hiding_decls),
+ ("Imports ", import_no),
+ (" ImpQual ", import_qual),
+ (" ImpAs ", import_as),
+ (" ImpAll ", import_all),
+ (" ImpPartial ", import_partial),
+ (" ImpHiding ", import_hiding),
("FixityDecls ", fixity_ds),
("DefaultDecls ", defalut_ds),
("TypeDecls ", type_ds),
("DataDecls ", data_ds),
+ ("NewTypeDecls ", newt_ds),
("DataConstrs ", data_constrs),
("DataDerivings ", data_derivs),
("ClassDecls ", class_ds),
pp_val (str, 0) = ppNil
pp_val (str, n) = ppBesides [ppStr str, ppInt n]
- (export_decls, export_mods) = getRawIEStrings exports
+ (export_decls, export_mods) = getRawExportees exports
type_decls = filter is_type_decl typedecls
data_decls = filter is_data_decl typedecls
+ newt_decls = filter is_newt_decl typedecls
export_ds = length export_decls
export_ms = length export_mods
fixity_ds = length fixities
defalut_ds = length defdecls
- type_ds = length type_decls
+ type_ds = length type_decls
data_ds = length data_decls
- class_ds = length classdecls
+ newt_ds = length newt_decls
+ class_ds = length classdecls
inst_ds = length instdecls
(val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
= count_binds binds
- (import_all, import_partial, partial_decls, import_hiding, hiding_decls)
- = foldr add5 (0,0,0,0,0) (map import_info imports)
+ (import_no, import_qual, import_as, import_all, import_partial, import_hiding)
+ = foldr add6 (0,0,0,0,0,0) (map import_info imports)
(data_constrs, data_derivs)
- = foldr add2 (0,0) (map data_info data_decls)
+ = foldr add2 (0,0) (map data_info (newt_decls ++ data_decls))
(class_method_ds, default_method_ds)
- = foldr add2 (0,0) (map class_info classdecls)
+ = foldr add2 (0,0) (map class_info classdecls)
(inst_method_ds, method_specs, method_inlines)
= foldr add3 (0,0,0) (map inst_info instdecls)
- data_specs = length (filter is_data_spec_sig typesigs)
- inst_specs = length (filter is_inst_spec_sig instsigs)
-
+ data_specs = length typesigs
+ inst_specs = length instsigs
count_binds EmptyBinds = (0,0,0,0,0)
count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
sig_info (Sig _ _ _ _) = (1,0,0,0)
sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
sig_info (SpecSig _ _ _ _) = (0,0,1,0)
- sig_info (InlineSig _ _ _) = (0,0,0,1)
+ sig_info (InlineSig _ _) = (0,0,0,1)
sig_info _ = (0,0,0,0)
- import_info (ImportAll _ _) = (1,0,0,0,0)
- import_info (ImportSome _ ds _) = (0,1,length ds,0,0)
- import_info (ImportButHide _ ds _) = (0,0,0,1,length ds)
+ import_info (ImportMod _ qual as spec)
+ = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
+ qual_info False = 0
+ qual_info True = 1
+ as_info Nothing = 0
+ as_info (Just _) = 1
+ spec_info Nothing = (0,0,0,1,0,0)
+ spec_info (Just (False, _)) = (0,0,0,0,1,0)
+ spec_info (Just (True, _)) = (0,0,0,0,0,1)
data_info (TyData _ _ _ constrs derivs _ _)
- = (length constrs, length derivs)
+ = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
+ data_info (TyNew _ _ _ constr derivs _ _)
+ = (length constr, case derivs of {Nothing -> 0; Just ds -> length ds})
class_info (ClassDecl _ _ _ meth_sigs def_meths _ _)
= case count_sigs meth_sigs of
(_,classops,_,_) ->
(classops, addpr (count_monobinds def_meths))
- inst_info (InstDecl _ _ _ inst_meths _ _ _ inst_sigs _ _)
- = case count_sigs inst_sigs of
+ inst_info (InstDecl _ _ inst_meths _ _ inst_sigs _ _)
+ = case count_sigs inst_sigs of
(_,_,ss,is) ->
(addpr (count_monobinds inst_meths), ss, is)
- is_type_decl (TySynonym _ _ _ _ _) = True
+ is_type_decl (TySynonym _ _ _ _) = True
is_type_decl _ = False
is_data_decl (TyData _ _ _ _ _ _ _) = True
is_data_decl _ = False
- is_data_spec_sig (SpecDataSig _ _ _) = True
- is_data_spec_sig _ = False
- is_inst_spec_sig (InstSpecSig _ _ _) = True
+ is_newt_decl (TyNew _ _ _ _ _ _ _) = True
+ is_newt_decl _ = False
addpr (x,y) = x+y
add1 x1 y1 = x1+y1
add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
+ add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
\end{code}
-
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MainMonad where
-import PreludeArray(_ByteArray)
-import SplitUniq(SplitUniqSupply)
-import Stdio(_FILE(..), fclose, fopen, fwrite)
-infixr 9 `thenMn`
-infixr 9 `thenMn_`
-type MainIO a = _State _RealWorld -> (a, _State _RealWorld)
-data SplitUniqSupply
-data _FILE = _FILE Addr#
-exitMn :: Int -> _State _RealWorld -> ((), _State _RealWorld)
-fclose :: _FILE -> _State _RealWorld -> (Int, _State _RealWorld)
-fopen :: [Char] -> [Char] -> _State _RealWorld -> (_FILE, _State _RealWorld)
-fwrite :: _ByteArray Int -> Int -> Int -> _FILE -> _State _RealWorld -> (Int, _State _RealWorld)
-getArgsMn :: _State _RealWorld -> ([[Char]], _State _RealWorld)
-getSplitUniqSupplyMn :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld)
-readMn :: [Char] -> _State _RealWorld -> ([Char], _State _RealWorld)
-returnMn :: a -> _State _RealWorld -> (a, _State _RealWorld)
-thenMn :: (_State _RealWorld -> (a, _State _RealWorld)) -> (a -> _State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld)
-thenMn_ :: (_State _RealWorld -> (a, _State _RealWorld)) -> (_State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld)
-writeMn :: [Char] -> [Char] -> _State _RealWorld -> ((), _State _RealWorld)
-instance Eq _FILE
-instance _CCallable _FILE
-instance _CReturnable _FILE
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[MainMonad]{I/O monad used in @Main@ module of the compiler}
module MainMonad (
MainIO(..),
-#ifndef __GLASGOW_HASKELL__
- mainIOtoDialogue,
- appendFileMn,
-#endif
returnMn,
thenMn,
thenMn_,
getArgsMn,
getSplitUniqSupplyMn,
exitMn,
-#if __GLASGOW_HASKELL__ >= 23
fopen, fclose, fwrite, _FILE(..),
-#endif
- SplitUniqSupply
+ UniqSupply
IF_ATTACK_PRAGMAS(COMMA getArgsPrimIO)
IF_ATTACK_PRAGMAS(COMMA appendFilePrimIO)
IF_ATTACK_PRAGMAS(COMMA appendChanPrimIO)
IF_ATTACK_PRAGMAS(COMMA mkSplitUniqSupply) -- profiling only, really
) where
-#ifdef __GLASGOW_HASKELL__
+#if __HASKELL1__ >= 3
+import LibSystem
+#endif
-# if __GLASGOW_HASKELL__ < 26
-import PreludePrimIO
-# endif
import PreludeGlaST
-#endif
+import Ubiq{-uitous-}
-import SplitUniq
-import Outputable
-import Util
+import UniqSupply ( mkSplitUniqSupply, UniqSupply )
infixr 9 `thenMn` -- right-associative, please
infixr 9 `thenMn_`
\end{code}
-For Glasgow Haskell, we'll eventually be able to use the underlying
-Glasgow I/O {\em directly}. However, for now we do the business
-through regular a @Dialogue@.
-
A value of type @MainIO a@ represents an I/O-performing computation
returning a value of type @a@. It is a function from the whole list
of responses-to-the-rest-of-the-program, to a triple consisting of:
returnMn :: a -> MainIO a
thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b
thenMn_ :: MainIO a -> MainIO b -> MainIO b
---foldlMn :: (a -> b -> MainIO a) -> a -> [b] -> MainIO a
+#if __HASKELL1__ < 3
readMn :: String{-channel-} -> MainIO String
writeMn :: String{-channel-} -> String -> MainIO ()
-#ifndef __GLASGOW_HASKELL__
-appendFileMn:: String{-filename-} -> String -> MainIO ()
+#else
+readMn :: Handle -> MainIO String
+writeMn :: Handle -> String -> MainIO ()
#endif
+
getArgsMn :: MainIO [String]
-getSplitUniqSupplyMn :: Char -> MainIO SplitUniqSupply
+getSplitUniqSupplyMn
+ :: Char -> MainIO UniqSupply
exitMn :: Int -> MainIO ()
-#ifdef __GLASGOW_HASKELL__
{-# INLINE returnMn #-}
{-# INLINE thenMn #-}
{-# INLINE thenMn_ #-}
-#endif
-
-{- INLINEd at its uses
-foldlMn f z [] = returnMn z
-foldlMn f z (x:xs) = f z x `thenMn` \ zz ->
- foldlMn f zz xs
--}
exitMn val
- = -- trace ("exitMn:"++(show val)) (
- if val /= 0
+ = if val /= 0
then error "Compilation had errors\n"
else returnMn ()
- -- )
-#ifdef __GLASGOW_HASKELL__
+#if __HASKELL1__ < 3
type MainIO a = PrimIO a
getArgsMn = getArgsPrimIO
getSplitUniqSupplyMn char = mkSplitUniqSupply char
-\end{code}
-
-\begin{code}
-#else {- ! __GLASGOW_HASKELL -}
-
-type MainIO a = (a -> Dialogue) -> Dialogue
-
--- returnMn :: x -> MainIO x
-returnMn x cont = cont x
-
--- thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b
-thenMn m k cont = m (\ a -> k a cont)
-
--- thenMn_ :: MainIO a -> MainIO b -> MainIO b
-thenMn_ m k cont = m (\ _ -> k cont)
-\end{code}
-
-\begin{code}
-mainIOtoDialogue :: MainIO () -> Dialogue
-
-mainIOtoDialogue io = io (\ _ _ -> [])
-
-readMn chan = readChanIO chan
-writeMn chan str = appendChanIO chan str
-appendFileMn fname str = appendFileIO fname str
-getArgsMn = getArgsIO
-
-getSplitUniqSupplyMn char = returnMn (mkSplitUniqSupply char)
-\end{code}
-
-\begin{code}
-processRequestIO :: Request -> MainIO Response
-processRequestIO req cont ~(resp:resps) = req : cont resp resps
-
-doneIO :: MainIO a
-doneIO cont = \ _ -> []
-
-data IoResult a = IoSucc a
- | IoFail IOError
-type IOE a = MainIO (IoResult a)
+#else {- 1.3 -}
-processRequestIOUnit :: Request -> IOE ()
-processRequestIOUnit req =
- processRequestIO req `thenMn` \ resp ->
- case resp of
- Success -> returnMn (IoSucc ())
- Str str -> error "funny Response, expected a Success"
- StrList strl -> error "funny Response, expected a Success"
- Failure ioerr -> returnMn (IoFail ioerr)
+type MainIO a = IO a
-processRequestIOString :: Request -> IOE String
-processRequestIOString req =
- processRequestIO req `thenMn` \ resp ->
- case resp of
- Success -> error "funny Response, expected a String"
- Str str -> returnMn (IoSucc str)
- StrList strl -> error "funny Response, expected a String"
- Failure ioerr -> returnMn (IoFail ioerr)
+returnMn = return
+thenMn = (>>=)
+thenMn_ = (>>)
-processRequestIOStringList :: Request -> IOE [String]
-processRequestIOStringList req =
- processRequestIO req `thenMn` \ resp ->
- case resp of
- Success -> error "funny Response, expected a [String]"
- Str str -> error "funny Response, expected a [String]"
- StrList strl -> returnMn (IoSucc strl)
- Failure ioerr -> returnMn (IoFail ioerr)
+readMn chan = hGetContents chan
+writeMn chan str = hPutStr chan str
+getArgsMn = getArgs
-readFileIOE :: String -> IOE String
-writeFileIOE :: String -> String -> IOE ()
-appendFileIOE :: String -> String -> IOE ()
-deleteFileIOE :: String -> IOE ()
-statusFileIOE :: String -> IOE String
-readChanIOE :: String -> IOE String
-appendChanIOE :: String -> String -> IOE ()
-statusChanIOE :: String -> IOE String
-echoIOE :: Bool -> IOE ()
-getArgsIOE :: IOE [String]
-getEnvIOE :: String -> IOE String
-setEnvIOE :: String -> String -> IOE ()
-sigActionIOE :: Int -> SigAct -> IOE ()
+getSplitUniqSupplyMn char
+ = mkSplitUniqSupply char `thenPrimIO` \ us ->
+ return us
-readFileIOE file = processRequestIOString ( ReadFile file )
-writeFileIOE file str = processRequestIOUnit ( WriteFile file str )
-appendFileIOE file str = processRequestIOUnit ( AppendFile file str )
-deleteFileIOE file = processRequestIOUnit ( DeleteFile file )
-statusFileIOE file = processRequestIOString ( StatusFile file )
-readChanIOE chan = processRequestIOString ( ReadChan chan )
-appendChanIOE chan str = processRequestIOUnit ( AppendChan chan str )
-statusChanIOE chan = processRequestIOString ( StatusChan chan )
-echoIOE bool = processRequestIOUnit ( Echo bool )
-getArgsIOE = processRequestIOStringList ( GetArgs )
-getEnvIOE var = processRequestIOString ( GetEnv var )
-setEnvIOE var obj = processRequestIOUnit ( SetEnv var obj )
-sigActionIOE sig act = processRequestIOUnit ( SigAction sig act )
-
-handleErrIO :: IoResult a -> MainIO a
-handleErrIO (IoSucc a) = returnMn a
-handleErrIO (IoFail ioerr) = exitIO ioerr
-
-readFileIO :: String -> MainIO String
-writeFileIO :: String -> String -> MainIO ()
-appendFileIO :: String -> String -> MainIO ()
-deleteFileIO :: String -> MainIO ()
-statusFileIO :: String -> MainIO String
-readChanIO :: String -> MainIO String
-appendChanIO :: String -> String -> MainIO ()
-statusChanIO :: String -> MainIO String
-echoIO :: Bool -> MainIO ()
-getArgsIO :: MainIO [String]
-getEnvIO :: String -> MainIO String
-setEnvIO :: String -> String -> MainIO ()
-sigActionIO :: Int -> SigAct -> MainIO ()
-
-readFileIO file = readFileIOE file `thenMn` handleErrIO
-writeFileIO file str = writeFileIOE file str `thenMn` handleErrIO
-appendFileIO file str = appendFileIOE file str `thenMn` handleErrIO
-deleteFileIO file = deleteFileIOE file `thenMn` handleErrIO
-statusFileIO file = statusFileIOE file `thenMn` handleErrIO
-readChanIO chan = readChanIOE chan `thenMn` handleErrIO
-appendChanIO chan str = appendChanIOE chan str `thenMn` handleErrIO
-statusChanIO chan = statusChanIOE chan `thenMn` handleErrIO
-echoIO bool = echoIOE bool `thenMn` handleErrIO
-getArgsIO = getArgsIOE `thenMn` handleErrIO
-getEnvIO var = getEnvIOE var `thenMn` handleErrIO
-setEnvIO var obj = setEnvIOE var obj `thenMn` handleErrIO
-sigActionIO sig act = sigActionIOE sig act `thenMn` handleErrIO
-
-exitIO :: IOError -> MainIO a
-
-exitIO (ReadError s) = error s
-exitIO (WriteError s) = error s
-exitIO (SearchError s) = error s
-exitIO (FormatError s) = error s
-exitIO (OtherError s) = error s
-\end{code}
-
-\begin{code}
-#endif {- ! __GLASGOW_HASKELL -}
+#endif {- 1.3 -}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MkIface where
-import Bag(Bag)
-import CE(CE(..))
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import FiniteMap(FiniteMap)
-import HsBinds(MonoBinds, Sig)
-import HsDecls(FixityDecl)
-import HsPat(InPat)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PrettyRep)
-import SimplEnv(UnfoldingDetails)
-import SrcLoc(SrcLoc)
-import StgSyn(StgBinding, StgRhs)
-import TCE(TCE(..))
-import TcInstDcls(InstInfo)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Bag a
-type CE = UniqFM Class
-data GlobalSwitch
-data FixityDecl a
-data Id
-data Name
-data PrettyRep
-data StgBinding a b
-type TCE = UniqFM TyCon
-data InstInfo
-data UniqFM a
-mkInterface :: (GlobalSwitch -> Bool) -> _PackedString -> (_PackedString -> Bool, _PackedString -> Bool) -> UniqFM UnfoldingDetails -> FiniteMap TyCon [(Bool, [Labda UniType])] -> ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo) -> [StgBinding Id Id] -> Int -> Bool -> PrettyRep
-
\begin{code}
#include "HsVersions.h"
-module MkIface (
- mkInterface,
+module MkIface ( mkInterface ) where
- -- and to make the interface self-sufficient...
- Bag, CE(..), GlobalSwitch, FixityDecl, Id,
- Name, PrettyRep, StgBinding, TCE(..), UniqFM, InstInfo
- ) where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-
-import AbsPrel ( mkLiftTy, pRELUDE_CORE, pRELUDE_BUILTIN )
-import AbsSyn ( FixityDecl(..), RenamedFixityDecl(..), MonoBinds,
+import PrelInfo ( mkLiftTy, pRELUDE_CORE, pRELUDE_BUILTIN )
+import HsSyn ( FixityDecl(..), RenamedFixityDecl(..), MonoBinds,
RenamedMonoBinds(..), Name, RenamedPat(..), Sig
)
-import AbsUniType
+import Type
import Bag
-import CE
-import CmdLineOpts -- ( GlobalSwitch(..) )
import FiniteMap
import Id
import IdInfo -- plenty from here
import Outputable
import Pretty
import StgSyn
-import TCE
import TcInstDcls ( InstInfo(..) )
import Util
\end{code}
Those @IdInfos@ were figured out long after the \tr{InstInfo} was
created.
-That's why we actually look at the final \tr{PlainStgBindings} that go
+That's why we actually look at the final \tr{StgBindings} that go
into the code-generator: they have the best @IdInfos@ on them.
Whenever, we are about to print info about an @Id@, we look in the
Ids-from-STG-bindings list to see if we have an ``equivalent'' @Id@
\end{enumerate}
\begin{code}
-mkInterface :: (GlobalSwitch -> Bool)
- -> FAST_STRING
+mkInterface :: FAST_STRING
-> (FAST_STRING -> Bool, -- is something in export list, explicitly?
FAST_STRING -> Bool) -- is a module among the "dotdot" exported modules?
-> IdEnv UnfoldingDetails
- -> FiniteMap TyCon [(Bool, [Maybe UniType])]
+ -> FiniteMap TyCon [(Bool, [Maybe Type])]
-> ([RenamedFixityDecl], -- interface info from the typecheck
- [Id],
- CE,
- TCE,
- Bag InstInfo)
- -> [PlainStgBinding]
+ [Id],
+ CE,
+ TCE,
+ Bag InstInfo)
+ -> [StgBinding]
-> Pretty
-mkInterface sw_chkr modname export_list_fns inline_env tycon_specs
+mkInterface modname export_list_fns inline_env tycon_specs
(fixity_decls, global_ids, ce, tce, inst_infos)
stg_binds
= let
exported_tycons = [ tc | tc <- rngTCE tce,
isExported tc,
- is_exportable_tycon_or_class sw_chkr export_list_fns tc ]
+ is_exportable_tycon_or_class export_list_fns tc ]
exported_classes = [ c | c <- rngCE ce,
isExported c,
- is_exportable_tycon_or_class sw_chkr export_list_fns c ]
+ is_exportable_tycon_or_class export_list_fns c ]
exported_inst_infos = [ i | i <- bagToList inst_infos,
- is_exported_inst_info sw_chkr export_list_fns i ]
+ is_exported_inst_info export_list_fns i ]
exported_vals
= [ v | v <- global_ids,
isExported v && not (isDataCon v) && not (isClassOpId v) ]
= foldr ( \ (tcs1, cls1) (tcs2, cls2)
-> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) )
(emptyBag, emptyBag)
- (map getMentionedTyConsAndClassesFromClass exported_classes ++
+ (map getMentionedTyConsAndClassesFromClass exported_classes ++
map getMentionedTyConsAndClassesFromTyCon exported_tycons ++
map getMentionedTyConsAndClassesFromId exported_vals ++
map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)
mentionable_classes
- = filter (is_mentionable sw_chkr) (bagToList mentioned_classes)
+ = filter is_mentionable (bagToList mentioned_classes)
mentionable_tycons
= [ tc | tc <- bagToList mentioned_tycons,
- is_mentionable sw_chkr tc,
+ is_mentionable tc,
not (isPrimTyCon tc) ]
- nondup_mentioned_tycons = fst (removeDups cmpTyCon mentionable_tycons)
- nondup_mentioned_classes = fst (removeDups cmpClass mentionable_classes)
+ nondup_mentioned_tycons = fst (removeDups cmp mentionable_tycons)
+ nondup_mentioned_classes = fst (removeDups cmp mentionable_classes)
-- Next: as discussed in the notes, we want the top-level
-- Ids straight from the final STG code, so we can use
else
-- trace ("mkIface:Ids:"++(ppShow 80 (ppr PprDebug global_ids))) (
ppAboves
- [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 6 #-}"),
+ [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
- do_import_decls sw_chkr modname
+ do_import_decls modname
sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
-- Mustn't give the data constructors to do_import_decls,
-- because they aren't explicitly imported; their tycon is.
- -- ToDo: modify if we ever add renaming properly.
- ppAboves (map (do_fixity sw_chkr) fixity_decls),
- ppAboves (map (pprIfaceClass sw_chkr better_id_fn inline_env) sorted_classes),
- ppAboves (map (do_tycon sw_chkr tycon_specs) sorted_tycons),
- ppAboves (map (do_value sw_chkr better_id_fn inline_env) sorted_vals),
- ppAboves (map (do_instance sw_chkr better_id_fn inline_env) sorted_inst_infos),
+ ppAboves (map do_fixity fixity_decls),
+ ppAboves (map (pprIfaceClass better_id_fn inline_env) sorted_classes),
+ ppAboves (map (do_tycon tycon_specs) sorted_tycons),
+ ppAboves (map (do_value better_id_fn inline_env) sorted_vals),
+ ppAboves (map (do_instance better_id_fn inline_env) sorted_inst_infos),
- ppChar '\n'
+ ppChar '\n'
]
-- )
where
Just xs -> naughty_trace cl xs
bad_id id
- = case (maybePurelyLocalType (getIdUniType id)) of
+ = case (maybePurelyLocalType (idType id)) of
Nothing -> False
Just xs -> naughty_trace id xs
%* *
%************************************************************************
-Not handling renaming yet (ToDo)
-
We gather up lots of (module, name) pairs for which we might print an
import declaration. We sort them, for the usual canonicalisation
reasons. NB: We {\em assume} the lists passed in don't have duplicates in
\begin{code}
do_import_decls
- :: (GlobalSwitch -> Bool)
- -> FAST_STRING
+ :: FAST_STRING
-> [Id] -> [Class] -> [TyCon]
-> Pretty
-do_import_decls sw_chkr mod_name vals classes tycons
+do_import_decls mod_name vals classes tycons
= let
- -- Conjure up (module, name, maybe_renaming) triples for all
+ -- Conjure up (module, name) pairs for all
-- the potentially import-decls things:
vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
- vals_names = map get_val_triple vals
- classes_names = map get_class_triple classes
- tycons_names = map get_tycon_triple tycons
+ vals_names = map get_val_pair vals
+ classes_names = map get_class_pair classes
+ tycons_names = map get_tycon_pair tycons
- -- sort the (module, name, renaming) triples and chop
+ -- sort the (module, name) pairs and chop
-- them into per-module groups:
ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names)
in
ppAboves (map print_a_decl per_module_groups)
where
- lt, same_module :: (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
- -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING]) -> Bool
+ lt, same_module :: (FAST_STRING, FAST_STRING)
+ -> (FAST_STRING, FAST_STRING) -> Bool
- lt (m1, ie1, _) (m2, ie2, _)
- = case _CMP_STRING_ m1 m2 of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
+ lt (m1, ie1, ie2)
+ = case (_CMP_STRING_ m1 m2) of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
same_module (m1, _, _) (m2, _, _) = m1 == m2
-
- compiling_the_prelude = sw_chkr CompilingPrelude
+
+ compiling_the_prelude = opt_CompilingPrelude
print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty
{-
try to do it as "normally" as possible.
-}
print_a_decl (ielist@((m,_,_) : _))
- | m == mod_name
+ | m == mod_name
|| (not compiling_the_prelude &&
(m == pRELUDE_CORE || m == pRELUDE_BUILTIN))
= ppNil
| otherwise
- = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
+ = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
- ppRparen,
- case (grab_non_Nothings [rns | (_,_,rns) <- ielist]) of
- [] -> ppNil
- renamings -> pp_renamings renamings
+ ppRparen
]
where
isnt_tycon_ish :: FAST_STRING -> Bool
= if isAvarop pstr then ppStr ("("++str++")") else ppPStr pstr
where
str = _UNPK_ pstr
-
- pp_renamings strs
- = ppBesides [ ppPStr SLIT(" renaming "), ppLparen, ppIntersperse pp'SP{-'-} (map ppPStr strs), ppRparen ]
\end{code}
-Most of the huff and puff here is to ferret out renaming strings.
-
\begin{code}
-get_val_triple :: Id -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
-get_class_triple :: Class -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
-get_tycon_triple :: TyCon -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING])
+get_val_pair :: Id -> (FAST_STRING, FAST_STRING)
+get_class_pair :: Class -> (FAST_STRING, FAST_STRING)
+get_tycon_pair :: TyCon -> (FAST_STRING, FAST_STRING)
-get_val_triple id
- = case (generic_triple id) of { (a,b,rn) ->
- (a,b,[rn]) }
+get_val_pair id
+ = generic_pair id
-get_class_triple clas
- = case (generic_triple clas) of { (orig_mod, orig_nm, clas_rn) ->
+get_class_pair clas
+ = case (generic_pair clas) of { (orig_mod, orig_nm) ->
let
nm_to_print = case (getExportFlag clas) of
ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
ExportAbs -> orig_nm
NotExported -> orig_nm
-
--- Ops don't have renaming info (bug) ToDo
--- ops = getClassOps clas
--- ops_rns = [ rn | (_,_,rn) <- map generic_triple ops ]
in
- (orig_mod, nm_to_print, [clas_rn]) }
+ (orig_mod, nm_to_print) }
-get_tycon_triple tycon
- = case (generic_triple tycon) of { (orig_mod, orig_nm, tycon_rn) ->
+get_tycon_pair tycon
+ = case (generic_pair tycon) of { (orig_mod, orig_nm) ->
let
nm_to_print = case (getExportFlag tycon) of
ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
NotExported -> orig_nm
cons = getTyConDataCons tycon
- cons_rns = [ rn | (_,_,rn) <- map generic_triple cons ]
in
- (orig_mod, nm_to_print, tycon_rn : cons_rns) }
+ (orig_mod, nm_to_print) }
-generic_triple thing
+generic_pair thing
= case (getOrigName thing) of { (orig_mod, orig_nm) ->
case (getOccurrenceName thing) of { occur_name ->
- (orig_mod, orig_nm,
- if orig_nm == occur_name
- then Nothing
- else Just (orig_nm _APPEND_ SLIT(" to ") _APPEND_ occur_name)
- )}}
+ (orig_mod, orig_nm) }}
\end{code}
%************************************************************************
\begin{code}
-do_fixity :: (GlobalSwitch -> Bool) -> RenamedFixityDecl -> Pretty
+do_fixity :: -> RenamedFixityDecl -> Pretty
-do_fixity sw_chkr fixity_decl
+do_fixity fixity_decl
= case (getExportFlag (get_name fixity_decl)) of
- ExportAll -> ppr (PprInterface sw_chkr) fixity_decl
+ ExportAll -> ppr PprInterface fixity_decl
_ -> ppNil
where
get_name (InfixL n _) = n
%************************************************************************
\begin{code}
-do_tycon :: (GlobalSwitch -> Bool) -> FiniteMap TyCon [(Bool, [Maybe UniType])] -> TyCon -> Pretty
+do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
-do_tycon sw_chkr tycon_specs_map tycon
- = pprTyCon (PprInterface sw_chkr) tycon tycon_specs
+do_tycon tycon_specs_map tycon
+ = pprTyCon PprInterface tycon tycon_specs
where
tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
\end{code}
%************************************************************************
\begin{code}
-do_value :: (GlobalSwitch -> Bool)
- -> (Id -> Id)
+do_value :: (Id -> Id)
-> IdEnv UnfoldingDetails
-> Id
-> Pretty
-do_value sw_chkr better_id_fn inline_env val
+do_value better_id_fn inline_env val
= let
- sty = PprInterface sw_chkr
+ sty = PprInterface
better_val = better_id_fn val
name_str = getOccurrenceName better_val -- NB: not orig name!
id_info = getIdInfo better_val
- val_ty = let
- orig_ty = getIdUniType val
- final_ty = getIdUniType better_val
+ val_ty = let
+ orig_ty = idType val
+ final_ty = idType better_val
in
-- ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
ASSERT (if (orig_ty == final_ty || mkLiftTy orig_ty == final_ty) then True else pprTrace "do_value:" (ppCat [ppr PprDebug val, ppr PprDebug better_val]) False)
-- The importing module must lift the Id before using the imported id_info
pp_id_info
- = if sw_chkr OmitInterfacePragmas
+ = if opt_OmitInterfacePragmas
|| boringIdInfo id_info
then ppNil
else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
ppPStr SLIT("#-}")]
in
ppAbove (ppCat [ppr_non_op name_str,
- ppPStr SLIT("::"), pprUniType sty val_ty])
+ ppPStr SLIT("::"), pprType sty val_ty])
pp_id_info
-- sadly duplicates Outputable.pprNonOp (ToDo)
from instance and class decls).
\begin{code}
-do_instance :: (GlobalSwitch -> Bool)
- -> (Id -> Id)
+do_instance :: (Id -> Id)
-> IdEnv UnfoldingDetails
-> InstInfo
-> Pretty
-do_instance sw_chkr better_id_fn inline_env
+do_instance better_id_fn inline_env
(InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
= let
- sty = PprInterface sw_chkr
+ sty = PprInterface
better_dfun = better_id_fn dfun_id
better_dfun_info = getIdInfo better_dfun
pp_the_list [p] = p
pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
- real_stuff
+ real_stuff
= ppCat [ppPStr SLIT("instance"),
ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
in
- if sw_chkr OmitInterfacePragmas
+ if opt_OmitInterfacePragmas
|| boringIdInfo better_dfun_info
then real_stuff
else ppAbove real_stuff
Classes usually don't need to be mentioned in interfaces, but if we're
compiling the prelude, then we treat them without special favours.
\begin{code}
-is_exportable_tycon_or_class sw_chkr export_list_fns tc
+is_exportable_tycon_or_class export_list_fns tc
= if not (fromPreludeCore tc) then
True
else
in_export_list_or_among_dotdot_modules
- (sw_chkr CompilingPrelude) -- ignore M.. stuff if compiling prelude
+ opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
export_list_fns tc
in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
any among_dotdot_modules (getInformingModules tc)
-- )
-is_mentionable sw_chkr tc
- = not (from_PreludeCore_or_Builtin tc) || (sw_chkr CompilingPrelude)
+is_mentionable tc
+ = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
where
from_PreludeCore_or_Builtin thing
= let
in
mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
-is_exported_inst_info sw_chkr export_list_fns
+is_exported_inst_info export_list_fns
(InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
= let
- is_fun_tycon = isFunType ty
-
seems_exported = instanceIsExported clas ty from_here
-
- (tycon, _, _) = getUniDataTyCon ty
+ (tycon, _, _) = getAppTyCon ty
in
- if (sw_chkr OmitReexportedInstances && not from_here) then
+ if (opt_OmitReexportedInstances && not from_here) then
False -- Flag says to violate Haskell rules, blatantly
- else if not (sw_chkr CompilingPrelude)
- || not (is_fun_tycon || fromPreludeCore tycon)
- || not (fromPreludeCore clas) then
+ else if not opt_CompilingPrelude
+ || not (isFunTyCon tycon || fromPreludeCore tycon)
+ || not (fromPreludeCore clas) then
seems_exported -- take what we got
else -- compiling Prelude & tycon/class are Prelude things...
from_here
|| in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
- || (not is_fun_tycon
- && in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon)
+ || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
\end{code}
\begin{code}
\begin{code}
getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
- = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
+ = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
case [ c | (c, _) <- dfun_theta ] of { theta_classes ->
(ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
}}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AbsCStixGen where
-import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import ClosureInfo(ClosureInfo)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import MachDesc(RegLoc, Target)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data AbstractC
-data Target
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply
-data StixTree
-genCodeAbstractC :: Target -> AbstractC -> SplitUniqSupply -> [[StixTree]]
-
genCodeAbstractC,
-- and, of course, that's not enough...
- AbstractC, Target, StixTree, SplitUniqSupply, SUniqSM(..)
+ AbstractC, Target, StixTree, UniqSupply, UniqSM(..)
) where
import AbsCSyn
-import AbsPrel ( PrimOp(..), primOpNeedsWrapper, isCompareOp
+import PrelInfo ( PrimOp(..), primOpNeedsWrapper, isCompareOp
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import CgCompInfo ( mIN_UPD_SIZE )
-import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI,
+import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI,
closureUpdReqd
)
-import MachDesc
+import MachDesc
import Maybes ( Maybe(..), maybeToBool )
-import Outputable
-import PrimKind ( isFloatingKind )
+import Outputable
+import PrimRep ( isFloatingRep )
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import Stix
+import Stix
import StixInfo ( genCodeInfoTable )
-import SplitUniq
-import Unique
+import UniqSupply
import Util
\end{code}
-- hacking with Uncle Will:
#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
-genCodeAbstractC
- :: Target
+genCodeAbstractC
+ :: Target
-> AbstractC
- -> SUniqSM [[StixTree]]
+ -> UniqSM [[StixTree]]
-genCodeAbstractC target_STRICT absC =
- mapSUs gentopcode (mkAbsCStmtList absC) `thenSUs` \ trees ->
- returnSUs ([StComment SLIT("Native Code")] : trees)
+genCodeAbstractC target_STRICT absC =
+ mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
+ returnUs ([StComment SLIT("Native Code")] : trees)
where
-- "target" munging things... ---
a2stix = amodeToStix target
\begin{code}
{-
- genCodeTopAbsC
- :: Target
+ genCodeTopAbsC
+ :: Target
-> AbstractC
- -> SUniqSM [StixTree]
+ -> UniqSM [StixTree]
-}
gentopcode (CCodeBlock label absC) =
- gencode absC `thenSUs` \ code ->
- returnSUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
+ gencode absC `thenUs` \ code ->
+ returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
- gentopcode stmt@(CStaticClosure label _ _ _) =
- genCodeStaticClosure stmt `thenSUs` \ code ->
- returnSUs (StSegment DataSegment : StLabel label : code [])
+ gentopcode stmt@(CStaticClosure label _ _ _) =
+ genCodeStaticClosure stmt `thenUs` \ code ->
+ returnUs (StSegment DataSegment : StLabel label : code [])
- gentopcode stmt@(CRetUnVector _ _) = returnSUs []
+ gentopcode stmt@(CRetUnVector _ _) = returnUs []
gentopcode stmt@(CFlatRetVector label _) =
- genCodeVecTbl stmt `thenSUs` \ code ->
- returnSUs (StSegment TextSegment : code [StLabel label])
+ genCodeVecTbl stmt `thenUs` \ code ->
+ returnUs (StSegment TextSegment : code [StLabel label])
gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
| slow_is_empty
- = genCodeInfoTable hp_rel a2stix stmt `thenSUs` \ itbl ->
- returnSUs (StSegment TextSegment : itbl [])
+ = genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl ->
+ returnUs (StSegment TextSegment : itbl [])
| otherwise
- = genCodeInfoTable hp_rel a2stix stmt `thenSUs` \ itbl ->
- gencode slow `thenSUs` \ slow_code ->
- returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
- slow_code [StFunEnd slow_lbl]))
+ = genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl ->
+ gencode slow `thenUs` \ slow_code ->
+ returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
+ slow_code [StFunEnd slow_lbl]))
where
slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
slow_lbl = entryLabelFromCI cl_info
gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
-- ToDo: what if this is empty? ------------------------^^^^
- genCodeInfoTable hp_rel a2stix stmt `thenSUs` \ itbl ->
- gencode slow `thenSUs` \ slow_code ->
- gencode fast `thenSUs` \ fast_code ->
- returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
- slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
- fast_code [StFunEnd fast_lbl])))
+ genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl ->
+ gencode slow `thenUs` \ slow_code ->
+ gencode fast `thenUs` \ fast_code ->
+ returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
+ slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
+ fast_code [StFunEnd fast_lbl])))
where
slow_lbl = entryLabelFromCI cl_info
fast_lbl = fastLabelFromCI cl_info
gentopcode absC =
- gencode absC `thenSUs` \ code ->
- returnSUs (StSegment TextSegment : code [])
+ gencode absC `thenUs` \ code ->
+ returnUs (StSegment TextSegment : code [])
\end{code}
\begin{code}
{-
- genCodeVecTbl
- :: Target
+ genCodeVecTbl
+ :: Target
-> AbstractC
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
-}
genCodeVecTbl (CFlatRetVector label amodes) =
- returnSUs (\xs -> vectbl : xs)
+ returnUs (\xs -> vectbl : xs)
where
- vectbl = StData PtrKind (reverse (map a2stix amodes))
+ vectbl = StData PtrRep (reverse (map a2stix amodes))
\end{code}
\begin{code}
{-
- genCodeStaticClosure
- :: Target
+ genCodeStaticClosure
+ :: Target
-> AbstractC
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
-}
genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes) =
- returnSUs (\xs -> table : xs)
+ returnUs (\xs -> table : xs)
where
- table = StData PtrKind (StCLbl info_lbl : body)
+ table = StData PtrRep (StCLbl info_lbl : body)
info_lbl = infoTableLabelFromCI cl_info
- body = if closureUpdReqd cl_info then
+ body = if closureUpdReqd cl_info then
take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
else
amodes'
amodes' = map amodeZeroVoid amodes
-- Watch out for VoidKinds...cf. PprAbsC
- amodeZeroVoid item
- | getAmodeKind item == VoidKind = StInt 0
+ amodeZeroVoid item
+ | getAmodeRep item == VoidRep = StInt 0
| otherwise = a2stix item
\end{code}
\begin{code}
{-
gencode
- :: Target
+ :: Target
-> AbstractC
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
-}
\end{code}
\begin{code}
- gencode AbsCNop = returnSUs id
-
-\end{code}
-
-OLD:@CComment@s are passed through as the corresponding @StComment@s.
-
-\begin{code}
-
- --UNUSED:gencode (CComment s) = returnSUs (\xs -> StComment s : xs)
+ gencode AbsCNop = returnUs id
\end{code}
\begin{code}
- gencode CSplitMarker = returnSUs id
+ gencode CSplitMarker = returnUs id
\end{code}
\begin{code}
gencode (AbsCStmts c1 c2) =
- gencode c1 `thenSUs` \ b1 ->
- gencode c2 `thenSUs` \ b2 ->
- returnSUs (b1 . b2)
+ gencode c1 `thenUs` \ b1 ->
+ gencode c2 `thenUs` \ b2 ->
+ returnUs (b1 . b2)
\end{code}
gencode (CInitHdr cl_info reg_rel _ _) =
let
- lhs = a2stix (CVal reg_rel PtrKind)
+ lhs = a2stix (CVal reg_rel PtrRep)
lbl = infoTableLabelFromCI cl_info
in
- returnSUs (\xs -> StAssign PtrKind lhs (StCLbl lbl) : xs)
+ returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
\end{code}
produce. In most cases, the type of the assignment is determined
by the type of the destination. However, when the destination can
have mixed types, the type of the assignment is ``StgWord'' (we use
-PtrKind for lack of anything better). Think: do we also want a cast
+PtrRep for lack of anything better). Think: do we also want a cast
of the source? Be careful about floats/doubles.
\begin{code}
gencode (CAssign lhs rhs)
- | getAmodeKind lhs == VoidKind = returnSUs id
+ | getAmodeRep lhs == VoidRep = returnUs id
| otherwise =
- let pk = getAmodeKind lhs
- pk' = if mixedTypeLocn lhs && not (isFloatingKind pk) then IntKind else pk
+ let pk = getAmodeRep lhs
+ pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
lhs' = a2stix lhs
rhs' = a2stix' rhs
in
- returnSUs (\xs -> StAssign pk' lhs' rhs' : xs)
+ returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
\end{code}
\begin{code}
gencode (CJump dest) =
- returnSUs (\xs -> StJump (a2stix dest) : xs)
+ returnUs (\xs -> StJump (a2stix dest) : xs)
gencode (CFallThrough (CLbl lbl _)) =
- returnSUs (\xs -> StFallThrough lbl : xs)
+ returnUs (\xs -> StFallThrough lbl : xs)
gencode (CReturn dest DirectReturn) =
- returnSUs (\xs -> StJump (a2stix dest) : xs)
+ returnUs (\xs -> StJump (a2stix dest) : xs)
gencode (CReturn table (StaticVectoredReturn n)) =
- returnSUs (\xs -> StJump dest : xs)
- where
- dest = StInd PtrKind (StIndex PtrKind (a2stix table)
+ returnUs (\xs -> StJump dest : xs)
+ where
+ dest = StInd PtrRep (StIndex PtrRep (a2stix table)
(StInt (toInteger (-n-1))))
gencode (CReturn table (DynamicVectoredReturn am)) =
- returnSUs (\xs -> StJump dest : xs)
- where
- dest = StInd PtrKind (StIndex PtrKind (a2stix table) dyn_off)
+ returnUs (\xs -> StJump dest : xs)
+ where
+ dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
\end{code}
-- ToDo (ADR?): use that liveness mask
| primOpNeedsWrapper op =
let
- saves = volsaves vols
+ saves = volsaves vols
restores = volrestores vols
in
p2stix (nonVoid results) op (nonVoid args)
- `thenSUs` \ code ->
- returnSUs (\xs -> saves ++ code (restores ++ xs))
+ `thenUs` \ code ->
+ returnUs (\xs -> saves ++ code (restores ++ xs))
| otherwise = p2stix (nonVoid results) op (nonVoid args)
where
- nonVoid = filter ((/= VoidKind) . getAmodeKind)
+ nonVoid = filter ((/= VoidRep) . getAmodeRep)
\end{code}
Now the if statement. Almost *all* flow of control are of this form.
@
if (am==lit) { absC } else { absCdef }
-@
+@
=>
@
IF am = lit GOTO l1:
- absC
+ absC
jump l2:
l1:
absCdef
\begin{code}
- gencode (CSwitch discrim alts deflt)
+ gencode (CSwitch discrim alts deflt)
= case alts of
[] -> gencode deflt
[(tag,alt_code)] -> case maybe_empty_deflt of
Nothing -> gencode alt_code
- Just dc -> mkIfThenElse discrim tag alt_code dc
+ Just dc -> mkIfThenElse discrim tag alt_code dc
[(tag1@(MachInt i1 _), alt_code1),
- (tag2@(MachInt i2 _), alt_code2)]
+ (tag2@(MachInt i2 _), alt_code2)]
| deflt_is_empty && i1 == 0 && i2 == 1
-> mkIfThenElse discrim tag1 alt_code1 alt_code2
| deflt_is_empty && i1 == 1 && i2 == 0
-> mkIfThenElse discrim tag2 alt_code2 alt_code1
-
+
-- If the @discrim@ is simple, then this unfolding is safe.
other | simple_discrim -> mkSimpleSwitches discrim alts deflt
-- Otherwise, we need to do a bit of work.
- other -> getSUnique `thenSUs` \ u ->
+ other -> getUnique `thenUs` \ u ->
gencode (AbsCStmts
- (CAssign (CTemp u pk) discrim)
- (CSwitch (CTemp u pk) alts deflt))
+ (CAssign (CTemp u pk) discrim)
+ (CSwitch (CTemp u pk) alts deflt))
where
maybe_empty_deflt = nonemptyAbsC deflt
Nothing -> True
Just _ -> False
- pk = getAmodeKind discrim
+ pk = getAmodeRep discrim
simple_discrim = case discrim of
CReg _ -> True
gencode (CMacroStmt macro args) = macro_code macro args
gencode (CCallProfCtrMacro macro _) =
- returnSUs (\xs -> StComment macro : xs)
+ returnUs (\xs -> StComment macro : xs)
gencode (CCallProfCCMacro macro _) =
- returnSUs (\xs -> StComment macro : xs)
+ returnUs (\xs -> StComment macro : xs)
\end{code}
\begin{code}
- intTag :: BasicLit -> Integer
+ intTag :: Literal -> Integer
intTag (MachChar c) = toInteger (ord c)
intTag (MachInt i _) = i
intTag _ = panic "intTag"
- fltTag :: BasicLit -> Rational
+ fltTag :: Literal -> Rational
fltTag (MachFloat f) = f
fltTag (MachDouble d) = d
fltTag _ = panic "fltTag"
{-
- mkSimpleSwitches
- :: Target
- -> CAddrMode -> [(BasicLit,AbstractC)] -> AbstractC
- -> SUniqSM StixTreeList
+ mkSimpleSwitches
+ :: Target
+ -> CAddrMode -> [(Literal,AbstractC)] -> AbstractC
+ -> UniqSM StixTreeList
-}
mkSimpleSwitches am alts absC =
- getUniqLabelNCG `thenSUs` \ udlbl ->
- getUniqLabelNCG `thenSUs` \ ujlbl ->
+ getUniqLabelNCG `thenUs` \ udlbl ->
+ getUniqLabelNCG `thenUs` \ ujlbl ->
let am' = a2stix am
joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
sortedAlts = naturalMergeSortLe leAlt joinedAlts
else
mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
)
- `thenSUs` \ alt_code ->
- gencode absC `thenSUs` \ dflt_code ->
+ `thenUs` \ alt_code ->
+ gencode absC `thenUs` \ dflt_code ->
- returnSUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
+ returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
where
- floating = isFloatingKind (getAmodeKind am)
+ floating = isFloatingRep (getAmodeRep am)
choices = length alts
(x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
We use jump tables when doing an integer switch on a relatively dense list of
alternatives. We expect to be given a list of alternatives, sorted by tag,
-and a range of values for which we are to generate a table. Of course, the tags of
+and a range of values for which we are to generate a table. Of course, the tags of
the alternatives should lie within the indicated range. The alternatives need
not cover the range; a default target is provided for the missing alternatives.
\begin{code}
{-
mkJumpTable
- :: Target
+ :: Target
-> StixTree -- discriminant
- -> [(BasicLit, AbstractC)] -- alternatives
+ -> [(Literal, AbstractC)] -- alternatives
-> Integer -- low tag
-> Integer -- high tag
-> CLabel -- default label
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
-}
mkJumpTable am alts lowTag highTag dflt =
- getUniqLabelNCG `thenSUs` \ utlbl ->
- mapSUs genLabel alts `thenSUs` \ branches ->
+ getUniqLabelNCG `thenUs` \ utlbl ->
+ mapUs genLabel alts `thenUs` \ branches ->
let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
offset = StPrim IntSubOp [am, StInt lowTag]
- jump = StJump (StInd PtrKind (StIndex PtrKind (StCLbl utlbl) offset))
+ jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
tlbl = StLabel utlbl
- table = StData PtrKind (mkTable branches [lowTag..highTag] [])
- in
- mapSUs mkBranch branches `thenSUs` \ alts ->
+ table = StData PtrRep (mkTable branches [lowTag..highTag] [])
+ in
+ mapUs mkBranch branches `thenUs` \ alts ->
- returnSUs (\xs -> cjmpLo : cjmpHi : jump :
- StSegment DataSegment : tlbl : table :
- StSegment TextSegment : foldr1 (.) alts xs)
+ returnUs (\xs -> cjmpLo : cjmpHi : jump :
+ StSegment DataSegment : tlbl : table :
+ StSegment TextSegment : foldr1 (.) alts xs)
where
- genLabel x = getUniqLabelNCG `thenSUs` \ lbl -> returnSUs (lbl, x)
+ genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
mkBranch (lbl,(_,alt)) =
- gencode alt `thenSUs` \ alt_code ->
- returnSUs (\xs -> StLabel lbl : alt_code xs)
+ gencode alt `thenUs` \ alt_code ->
+ returnUs (\xs -> StLabel lbl : alt_code xs)
mkTable _ [] tbl = reverse tbl
mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
so long as they are not mixed. (We assume that the type of the discriminant
determines the type of the alternatives.)
-As with the jump table approach, if a join is necessary after the switch, the
+As with the jump table approach, if a join is necessary after the switch, the
alternatives should already finish with a jump to the join point.
\begin{code}
{-
- mkBinaryTree
- :: Target
+ mkBinaryTree
+ :: Target
-> StixTree -- discriminant
-> Bool -- floating point?
- -> [(BasicLit, AbstractC)] -- alternatives
+ -> [(Literal, AbstractC)] -- alternatives
-> Int -- number of choices
- -> BasicLit -- low tag
- -> BasicLit -- high tag
+ -> Literal -- low tag
+ -> Literal -- high tag
-> CLabel -- default code label
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
-}
- mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
+ mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
| rangeOfOne = gencode alt
- | otherwise =
+ | otherwise =
let tag' = a2stix (CLit tag)
cmpOp = if floating then DoubleNeOp else IntNeOp
test = StPrim cmpOp [am, tag']
cjmp = StCondJump udlbl test
in
- gencode alt `thenSUs` \ alt_code ->
- returnSUs (\xs -> cjmp : alt_code xs)
+ gencode alt `thenUs` \ alt_code ->
+ returnUs (\xs -> cjmp : alt_code xs)
- where
+ where
rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
-- When there is only one possible tag left in range, we skip the comparison
mkBinaryTree am floating alts choices lowTag highTag udlbl =
- getUniqLabelNCG `thenSUs` \ uhlbl ->
+ getUniqLabelNCG `thenUs` \ uhlbl ->
let tag' = a2stix (CLit splitTag)
cmpOp = if floating then DoubleGeOp else IntGeOp
test = StPrim cmpOp [am, tag']
cjmp = StCondJump uhlbl test
in
mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
- `thenSUs` \ lo_code ->
+ `thenUs` \ lo_code ->
mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
- `thenSUs` \ hi_code ->
+ `thenUs` \ hi_code ->
- returnSUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
+ returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
where
half = choices `div` 2
\begin{code}
{-
- mkIfThenElse
- :: Target
+ mkIfThenElse
+ :: Target
-> CAddrMode -- discriminant
- -> BasicLit -- tag
+ -> Literal -- tag
-> AbstractC -- if-part
-> AbstractC -- else-part
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
-}
mkIfThenElse discrim tag alt deflt =
- getUniqLabelNCG `thenSUs` \ ujlbl ->
- getUniqLabelNCG `thenSUs` \ utlbl ->
+ getUniqLabelNCG `thenUs` \ ujlbl ->
+ getUniqLabelNCG `thenUs` \ utlbl ->
let discrim' = a2stix discrim
tag' = a2stix (CLit tag)
- cmpOp = if (isFloatingKind (getAmodeKind discrim)) then DoubleNeOp else IntNeOp
+ cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
test = StPrim cmpOp [discrim', tag']
cjmp = StCondJump utlbl test
dest = StLabel utlbl
join = StLabel ujlbl
in
- gencode (mkJoin alt ujlbl) `thenSUs` \ alt_code ->
- gencode deflt `thenSUs` \ dflt_code ->
- returnSUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
+ gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
+ gencode deflt `thenUs` \ dflt_code ->
+ returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
mkJoin :: AbstractC -> CLabel -> AbstractC
-mkJoin code lbl
- | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrKind))
+mkJoin code lbl
+ | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
| otherwise = code
\end{code}
ft (CJump _) if_empty = False
ft (CReturn _ _) if_empty = False
- ft (CSwitch _ alts deflt) if_empty
+ ft (CSwitch _ alts deflt) if_empty
= ft deflt if_empty ||
or [ft alt if_empty | (_,alt) <- alts]
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AlphaCode where
-import AbsCSyn(MagicId)
-import AsmRegAlloc(MachineCode, MachineRegisters, Reg)
-import BitSet(BitSet)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import FiniteMap(FiniteMap)
-import Maybes(Labda)
-import OrdList(OrdList)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import Stix(CodeSegment)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Addr = AddrImm Imm | AddrReg Reg | AddrRegImm Reg Imm
-type AlphaCode = OrdList AlphaInstr
-data AlphaInstr
- = LD Size Reg Addr | LDA Reg Addr | LDAH Reg Addr | LDGP Reg Addr | LDI Size Reg Imm | ST Size Reg Addr | CLR Reg | ABS Size RI Reg | NEG Size Bool RI Reg | ADD Size Bool Reg RI Reg | SADD Size Size Reg RI Reg | SUB Size Bool Reg RI Reg | SSUB Size Size Reg RI Reg | MUL Size Bool Reg RI Reg | DIV Size Bool Reg RI Reg | REM Size Bool Reg RI Reg | NOT RI Reg | AND Reg RI Reg | ANDNOT Reg RI Reg | OR Reg RI Reg | ORNOT Reg RI Reg | XOR Reg RI Reg | XORNOT Reg RI Reg | SLL Reg RI Reg | SRL Reg RI Reg | SRA Reg RI Reg | ZAP Reg RI Reg | ZAPNOT Reg RI Reg | NOP | CMP Cond Reg RI Reg | FCLR Reg | FABS Reg Reg | FNEG Size Reg Reg | FADD Size Reg Reg Reg | FDIV Size Reg Reg Reg | FMUL Size Reg Reg Reg | FSUB Size Reg Reg Reg | CVTxy Size Size Reg Reg | FCMP Size Cond Reg Reg Reg | FMOV Reg Reg | BI Cond Reg Imm | BF Cond Reg Imm | BR Imm | JMP Reg Addr Int | BSR Imm Int | JSR Reg Addr Int | LABEL CLabel | FUNBEGIN CLabel | FUNEND CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm]
-data AlphaRegs
-data MagicId
-data Reg
-data BitSet
-data CLabel
-data CSeq
-data Cond = EQ | LT | LE | ULT | ULE | NE | GT | GE | ALWAYS | NEVER
-data FiniteMap a b
-data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq
-data OrdList a
-data PrimKind
-data CodeSegment
-data RI = RIReg Reg | RIImm Imm
-data Size = B | BU | W | WU | L | Q | FF | DF | GF | SF | TF
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-argRegs :: [(Reg, Reg)]
-baseRegOffset :: MagicId -> Int
-callerSaves :: MagicId -> Bool
-f0 :: Reg
-freeRegs :: [Reg]
-gp :: Reg
-kindToSize :: PrimKind -> Size
-printLabeledCodes :: PprStyle -> [AlphaInstr] -> CSeq
-pv :: Reg
-ra :: Reg
-reservedRegs :: [Int]
-sp :: Reg
-stgRegMap :: MagicId -> Labda Reg
-strImmLab :: [Char] -> Imm
-v0 :: Reg
-zero :: Reg
-instance MachineCode AlphaInstr
-instance MachineRegisters AlphaRegs
-
v0, f0, sp, ra, pv, gp, zero, argRegs,
- freeRegs, reservedRegs,
+ freeRegs, reservedRegs
-- and, for self-sufficiency ...
- CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..),
- UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet
) where
IMPORT_Trace
Reg(..), RegUsage(..), RegLiveness(..)
)
import BitSet
-import CLabelInfo ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
+import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
import FiniteMap
import Maybes ( Maybe(..), maybeToBool )
import OrdList ( OrdList, mkUnitList, flattenOrdList )
import Outputable
-import PrimKind ( PrimKind(..) )
+import PrimRep ( PrimRep(..) )
import UniqSet
import Stix
import Unpretty
(ints, floats) = partition (< 32) xs
floats' = map (subtract 32) floats
- possibleMRegs FloatKind (SRegs _ floats) = [ x + 32 | x <- listBS floats]
- possibleMRegs DoubleKind (SRegs _ floats) = [ x + 32 | x <- listBS floats]
+ possibleMRegs FloatRep (SRegs _ floats) = [ x + 32 | x <- listBS floats]
+ possibleMRegs DoubleRep (SRegs _ floats) = [ x + 32 | x <- listBS floats]
possibleMRegs _ (SRegs ints _) = listBS ints
useMReg (SRegs ints floats) n =
SRegs ints' floats' = mkMRegs xs
instance MachineCode AlphaInstr where
- -- Alas, we don't do anything clever with our OrdLists
---OLD:
--- flatten = flattenOrdList
-
regUsage = alphaRegUsage
regLiveness = alphaRegLiveness
patchRegs = alphaPatchRegs
spRel :: Int -> Addr
spRel n = AddrRegImm sp (ImmInt (n * 8))
-kindToSize :: PrimKind -> Size
-kindToSize PtrKind = Q
-kindToSize CodePtrKind = Q
-kindToSize DataPtrKind = Q
-kindToSize RetKind = Q
-kindToSize InfoPtrKind = Q
-kindToSize CostCentreKind = Q
-kindToSize CharKind = BU
-kindToSize IntKind = Q
-kindToSize WordKind = Q
-kindToSize AddrKind = Q
-kindToSize FloatKind = TF
-kindToSize DoubleKind = TF
-kindToSize ArrayKind = Q
-kindToSize ByteArrayKind = Q
-kindToSize StablePtrKind = Q
-kindToSize MallocPtrKind = Q
+kindToSize :: PrimRep -> Size
+kindToSize PtrRep = Q
+kindToSize CodePtrRep = Q
+kindToSize DataPtrRep = Q
+kindToSize RetRep = Q
+kindToSize CostCentreRep = Q
+kindToSize CharRep = BU
+kindToSize IntRep = Q
+kindToSize WordRep = Q
+kindToSize AddrRep = Q
+kindToSize FloatRep = TF
+kindToSize DoubleRep = TF
+kindToSize ArrayRep = Q
+kindToSize ByteArrayRep = Q
+kindToSize StablePtrRep = Q
+kindToSize MallocPtrRep = Q
\end{code}
noUsage :: RegUsage
noUsage = RU emptyUniqSet emptyUniqSet
---OLD:
---endUsage :: RegUsage
---endUsage = RU emptyUniqSet freeSet
-
-- Color me CAF-like
argSet :: Int -> UniqSet Reg
argSet 0 = emptyUniqSet
BSR _ _ -> RL live future
JSR _ _ _ -> RL live future
LABEL lbl -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live))
- _ -> info
+ _ -> info
where
lookup lbl = case lookupFM env lbl of
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AlphaDesc where
-import AbsCSyn(MagicId)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data MagicId
-data SwitchResult
-data RegLoc
-data PprStyle
-data PrimKind
-data SMRep
-data StixTree
-mkAlpha :: (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char])
-
#include "HsVersions.h"
module AlphaDesc (
- mkAlpha,
+ mkAlpha
-- and assorted nonsense referenced by the class methods
-
- PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult
-
) where
import AbsCSyn
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..),
RegUsage(..), RegLiveness(..), FutureLive(..)
)
-import CLabelInfo ( CLabel )
+import CLabel ( CLabel )
import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet,
switchIsOn, SwitchResult(..)
)
import HeapOffs ( hpRelToInt )
-import MachDesc
+import MachDesc
import Maybes ( Maybe(..) )
-import OrdList
-import Outputable
-import PrimKind ( PrimKind(..) )
+import OrdList
+import Outputable
+import PrimRep ( PrimRep(..) )
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import AlphaCode
+import AlphaCode
import AlphaGen ( alphaCodeGen )
import Stix
import StixMacro
import StixPrim
-import SplitUniq
-import Unique
+import UniqSupply
import Util
\end{code}
StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
BaseReg -> sStLitLbl SLIT("MainRegTable")
- Hp -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo"))
- HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+8"))
- TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*8)])
- where
- r2 = VanillaReg PtrKind ILIT(2)
+ Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
+ HpLim -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo+8"))
+ TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, StInt (1*8)])
+ where
+ r2 = VanillaReg PtrRep ILIT(2)
infoptr = case alphaReg switches r2 of
Always tree -> tree
Save _ -> StReg (StixMagicId r2)
baseLoc = case stgRegMap BaseReg of
Just _ -> StReg (StixMagicId BaseReg)
Nothing -> sStLitLbl SLIT("MainRegTable")
- offset = baseRegOffset x
-
+ offset = baseRegOffset x
+
\end{code}
Sizes in bytes.
\begin{code}
-vsaves switches vols =
+vsaves switches vols =
map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
where
- save x = StAssign (kindFromMagicId x) loc reg
+ save x = StAssign (kindFromMagicId x) loc reg
where reg = StReg (StixMagicId x)
loc = case alphaReg switches x of
Save loc -> loc
Always loc -> panic "vsaves"
-vrests switches vols =
- map restore ((filter callerSaves)
+vrests switches vols =
+ map restore ((filter callerSaves)
([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,{-ActivityReg,-}StkStubReg,StdUpdRetVecReg] ++ vols))
where
- restore x = StAssign (kindFromMagicId x) reg loc
+ restore x = StAssign (kindFromMagicId x) reg loc
where reg = StReg (StixMagicId x)
loc = case alphaReg switches x of
Save loc -> loc
charLikeSize, intLikeSize :: Target -> Int
-charLikeSize target =
- size PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
+charLikeSize target =
+ size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
-intLikeSize target =
- size PtrKind * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
+intLikeSize target =
+ size PtrRep * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
mhs switches = StInt (toInteger words)
- where
+ where
words = fhs switches + vhs switches (MuTupleRep 0)
dhs switches = StInt (toInteger words)
- where
+ where
words = fhs switches + vhs switches (DataRep 0)
\end{code}
mkAlpha :: (GlobalSwitch -> SwitchResult)
-> (Target,
- (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen
+ (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen
Bool, -- underscore
(String -> String)) -- fmtAsmLbl
-mkAlpha switches =
+mkAlpha switches =
let
fhs' = fhs switches
vhs' = vhs switches
alphaReg' = alphaReg switches
vsaves' = vsaves switches
vrests' = vrests switches
- hprel = hpRelToInt target
- as = amodeCode target
- as' = amodeCode' target
+ hprel = hpRelToInt target
+ as = amodeCode target
+ as' = amodeCode' target
csz = charLikeSize target
isz = intLikeSize target
mhs' = mhs switches
dhs' = dhs switches
ps = genPrimCode target
mc = genMacroCode target
- hc = doHeapCheck --UNUSED NOW: target
+ hc = doHeapCheck
target = mkTarget {-switches-} fhs' vhs' alphaReg' {-id-} size
hprel as as'
(vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AlphaGen where
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data CSeq
-data PprStyle
-data StixTree
-alphaCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
-
IMPORT_Trace
import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
Reg(..), RegLiveness(..), RegUsage(..), FutureLive(..),
MachineRegisters(..), MachineCode(..)
)
-import CLabelInfo ( CLabel, isAsmTemp )
+import CLabel ( CLabel, isAsmTemp )
import AlphaCode {- everything -}
import MachDesc
import Maybes ( maybeToBool, Maybe(..) )
import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
import Outputable
-import PrimKind ( PrimKind(..), isFloatingKind )
import AlphaDesc
import Stix
-import SplitUniq
-import Unique
+import UniqSupply
import Pretty
import Unpretty
import Util
\begin{code}
-alphaCodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
-alphaCodeGen sty trees =
- mapSUs genAlphaCode trees `thenSUs` \ dynamicCodes ->
+alphaCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
+alphaCodeGen sty trees =
+ mapUs genAlphaCode trees `thenUs` \ dynamicCodes ->
let
staticCodes = scheduleAlphaCode dynamicCodes
pretty = printLabeledCodes sty staticCodes
in
- returnSUs pretty
+ returnUs pretty
\end{code}
\begin{code}
-data Register
- = Fixed Reg PrimKind (CodeBlock AlphaInstr)
- | Any PrimKind (Reg -> (CodeBlock AlphaInstr))
+data Register
+ = Fixed Reg PrimRep (CodeBlock AlphaInstr)
+ | Any PrimRep (Reg -> (CodeBlock AlphaInstr))
registerCode :: Register -> Reg -> CodeBlock AlphaInstr
registerCode (Fixed _ _ code) reg = code
registerName (Fixed reg _ _) _ = reg
registerName (Any _ _) reg = reg
-registerKind :: Register -> PrimKind
+registerKind :: Register -> PrimRep
registerKind (Fixed _ pk _) = pk
registerKind (Any pk _) = pk
asmParThen :: [AlphaCode] -> CodeBlock AlphaInstr
asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-returnInstr :: AlphaInstr -> SUniqSM (CodeBlock AlphaInstr)
-returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
+returnInstr :: AlphaInstr -> UniqSM (CodeBlock AlphaInstr)
+returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-returnInstrs :: [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr)
-returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
+returnInstrs :: [AlphaInstr] -> UniqSM (CodeBlock AlphaInstr)
+returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-returnSeq :: (CodeBlock AlphaInstr) -> [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr)
-returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+returnSeq :: (CodeBlock AlphaInstr) -> [AlphaInstr] -> UniqSM (CodeBlock AlphaInstr)
+returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
mkSeqInstr :: AlphaInstr -> (CodeBlock AlphaInstr)
mkSeqInstr instr code = mkSeqList (asmInstr instr) code
\begin{code}
-genAlphaCode :: [StixTree] -> SUniqSM (AlphaCode)
+genAlphaCode :: [StixTree] -> UniqSM (AlphaCode)
genAlphaCode trees =
- mapSUs getCode trees `thenSUs` \ blocks ->
- returnSUs (foldr (.) id blocks asmVoid)
+ mapUs getCode trees `thenUs` \ blocks ->
+ returnUs (foldr (.) id blocks asmVoid)
\end{code}
\begin{code}
-getCode
+getCode
:: StixTree -- a stix statement
- -> SUniqSM (CodeBlock AlphaInstr)
+ -> UniqSM (CodeBlock AlphaInstr)
getCode (StSegment seg) = returnInstr (SEGMENT seg)
getCode (StAssign pk dst src)
- | isFloatingKind pk = assignFltCode pk dst src
+ | isFloatingRep pk = assignFltCode pk dst src
| otherwise = assignIntCode pk dst src
getCode (StLabel lab) = returnInstr (LABEL lab)
getCode (StCondJump lbl arg) = genCondJump lbl arg
-getCode (StData kind args) =
- mapAndUnzipSUs getData args `thenSUs` \ (codes, imms) ->
- returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
- (foldr1 (.) codes xs))
+getCode (StData kind args) =
+ mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
+ returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
+ (foldr1 (.) codes xs))
where
- getData :: StixTree -> SUniqSM (CodeBlock AlphaInstr, Imm)
- getData (StInt i) = returnSUs (id, ImmInteger i)
-#if __GLASGOW_HASKELL__ >= 23
--- getData (StDouble d) = returnSUs (id, strImmLab (_showRational 30 d))
- getData (StDouble d) = returnSUs (id, ImmLab (prettyToUn (ppRational d)))
-#else
- getData (StDouble d) = returnSUs (id, strImmLab (show d))
-#endif
- getData (StLitLbl s) = returnSUs (id, ImmLab s)
- getData (StLitLit s) = returnSUs (id, strImmLab (cvtLitLit (_UNPK_ s)))
- getData (StString s) =
- getUniqLabelNCG `thenSUs` \ lbl ->
- returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
- getData (StCLbl l) = returnSUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
+ getData :: StixTree -> UniqSM (CodeBlock AlphaInstr, Imm)
+ getData (StInt i) = returnUs (id, ImmInteger i)
+ getData (StDouble d) = returnUs (id, ImmLab (prettyToUn (ppRational d)))
+ getData (StLitLbl s) = returnUs (id, ImmLab s)
+ getData (StLitLit s) = returnUs (id, strImmLab (cvtLitLit (_UNPK_ s)))
+ getData (StString s) =
+ getUniqLabelNCG `thenUs` \ lbl ->
+ returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
+ getData (StCLbl l) = returnUs (id, ImmCLbl l)
+
+getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
getCode (StComment s) = returnInstr (COMMENT s)
\begin{code}
-getReg :: StixTree -> SUniqSM Register
+getReg :: StixTree -> UniqSM Register
getReg (StReg (StixMagicId stgreg)) =
case stgRegMap stgreg of
- Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
+ Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
-- cannae be Nothing
-getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
+getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
getReg (StDouble d) =
- getUniqLabelNCG `thenSUs` \ lbl ->
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getUniqLabelNCG `thenUs` \ lbl ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
-#if __GLASGOW_HASKELL__ >= 23
--- DATA TF [strImmLab (_showRational 30 d)],
DATA TF [ImmLab (prettyToUn (ppRational d))],
-#else
- DATA TF [strImmLab (show d)],
-#endif
SEGMENT TextSegment,
LDA tmp (AddrImm (ImmCLbl lbl)),
LD TF dst (AddrReg tmp)]
in
- returnSUs (Any DoubleKind code)
+ returnUs (Any DoubleRep code)
getReg (StString s) =
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
SEGMENT TextSegment,
LDA dst (AddrImm (ImmCLbl lbl))]
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
SEGMENT TextSegment,
LDA dst (AddrImm (ImmCLbl lbl))]
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
where
xs = _UNPK_ (_TAIL_ s)
getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
-getReg (StCall fn kind args) =
- genCCall fn kind args `thenSUs` \ call ->
- returnSUs (Fixed reg kind call)
+getReg (StCall fn kind args) =
+ genCCall fn kind args `thenUs` \ call ->
+ returnUs (Fixed reg kind call)
where
- reg = if isFloatingKind kind then f0 else v0
+ reg = if isFloatingRep kind then f0 else v0
-getReg (StPrim primop args) =
+getReg (StPrim primop args) =
case primop of
CharGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x]
IntRemOp -> trivialCode (REM Q False) args
IntNegOp -> trivialUCode (NEG Q False) args
IntAbsOp -> trivialUCode (ABS Q) args
-
+
AndOp -> trivialCode AND args
OrOp -> trivialCode OR args
NotOp -> trivialUCode NOT args
ISllOp -> panic "AlphaGen:isll"
ISraOp -> panic "AlphaGen:isra"
ISrlOp -> panic "AlphaGen:isrl"
-
+
IntGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x]
IntGeOp -> case args of [x,y] -> trivialCode (CMP LE) [y,x]
IntEqOp -> trivialCode (CMP EQ) args
FloatLtOp -> cmpFCode (FCMP TF LT) NE args
FloatLeOp -> cmpFCode (FCMP TF LE) NE args
- FloatExpOp -> call SLIT("exp") DoubleKind
- FloatLogOp -> call SLIT("log") DoubleKind
- FloatSqrtOp -> call SLIT("sqrt") DoubleKind
-
- FloatSinOp -> call SLIT("sin") DoubleKind
- FloatCosOp -> call SLIT("cos") DoubleKind
- FloatTanOp -> call SLIT("tan") DoubleKind
-
- FloatAsinOp -> call SLIT("asin") DoubleKind
- FloatAcosOp -> call SLIT("acos") DoubleKind
- FloatAtanOp -> call SLIT("atan") DoubleKind
-
- FloatSinhOp -> call SLIT("sinh") DoubleKind
- FloatCoshOp -> call SLIT("cosh") DoubleKind
- FloatTanhOp -> call SLIT("tanh") DoubleKind
-
- FloatPowerOp -> call SLIT("pow") DoubleKind
+ FloatExpOp -> call SLIT("exp") DoubleRep
+ FloatLogOp -> call SLIT("log") DoubleRep
+ FloatSqrtOp -> call SLIT("sqrt") DoubleRep
+
+ FloatSinOp -> call SLIT("sin") DoubleRep
+ FloatCosOp -> call SLIT("cos") DoubleRep
+ FloatTanOp -> call SLIT("tan") DoubleRep
+
+ FloatAsinOp -> call SLIT("asin") DoubleRep
+ FloatAcosOp -> call SLIT("acos") DoubleRep
+ FloatAtanOp -> call SLIT("atan") DoubleRep
+
+ FloatSinhOp -> call SLIT("sinh") DoubleRep
+ FloatCoshOp -> call SLIT("cosh") DoubleRep
+ FloatTanhOp -> call SLIT("tanh") DoubleRep
+
+ FloatPowerOp -> call SLIT("pow") DoubleRep
DoubleAddOp -> trivialFCode (FADD TF) args
DoubleSubOp -> trivialFCode (FSUB TF) args
DoubleMulOp -> trivialFCode (FMUL TF) args
DoubleDivOp -> trivialFCode (FDIV TF) args
DoubleNegOp -> trivialUFCode (FNEG TF) args
-
+
DoubleGtOp -> cmpFCode (FCMP TF LE) EQ args
DoubleGeOp -> cmpFCode (FCMP TF LT) EQ args
DoubleEqOp -> cmpFCode (FCMP TF EQ) NE args
DoubleLtOp -> cmpFCode (FCMP TF LT) NE args
DoubleLeOp -> cmpFCode (FCMP TF LE) NE args
- DoubleExpOp -> call SLIT("exp") DoubleKind
- DoubleLogOp -> call SLIT("log") DoubleKind
- DoubleSqrtOp -> call SLIT("sqrt") DoubleKind
-
- DoubleSinOp -> call SLIT("sin") DoubleKind
- DoubleCosOp -> call SLIT("cos") DoubleKind
- DoubleTanOp -> call SLIT("tan") DoubleKind
-
- DoubleAsinOp -> call SLIT("asin") DoubleKind
- DoubleAcosOp -> call SLIT("acos") DoubleKind
- DoubleAtanOp -> call SLIT("atan") DoubleKind
-
- DoubleSinhOp -> call SLIT("sinh") DoubleKind
- DoubleCoshOp -> call SLIT("cosh") DoubleKind
- DoubleTanhOp -> call SLIT("tanh") DoubleKind
-
- DoublePowerOp -> call SLIT("pow") DoubleKind
-
- OrdOp -> coerceIntCode IntKind args
+ DoubleExpOp -> call SLIT("exp") DoubleRep
+ DoubleLogOp -> call SLIT("log") DoubleRep
+ DoubleSqrtOp -> call SLIT("sqrt") DoubleRep
+
+ DoubleSinOp -> call SLIT("sin") DoubleRep
+ DoubleCosOp -> call SLIT("cos") DoubleRep
+ DoubleTanOp -> call SLIT("tan") DoubleRep
+
+ DoubleAsinOp -> call SLIT("asin") DoubleRep
+ DoubleAcosOp -> call SLIT("acos") DoubleRep
+ DoubleAtanOp -> call SLIT("atan") DoubleRep
+
+ DoubleSinhOp -> call SLIT("sinh") DoubleRep
+ DoubleCoshOp -> call SLIT("cosh") DoubleRep
+ DoubleTanhOp -> call SLIT("tanh") DoubleRep
+
+ DoublePowerOp -> call SLIT("pow") DoubleRep
+
+ OrdOp -> coerceIntCode IntRep args
ChrOp -> chrCode args
-
+
Float2IntOp -> coerceFP2Int args
Int2FloatOp -> coerceInt2FP args
Double2IntOp -> coerceFP2Int args
Int2DoubleOp -> coerceInt2FP args
-
+
Double2FloatOp -> coerceFltCode args
Float2DoubleOp -> coerceFltCode args
call fn pk = getReg (StCall fn pk args)
getReg (StInd pk mem) =
- getAmode mem `thenSUs` \ amode ->
- let
+ getAmode mem `thenUs` \ amode ->
+ let
code = amodeCode amode
src = amodeAddr amode
size = kindToSize pk
code__2 dst = code . mkSeqInstr (LD size dst src)
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
getReg (StInt i)
| is8Bits i =
let
code dst = mkSeqInstr (OR zero (RIImm src) dst)
in
- returnSUs (Any IntKind code)
+ returnUs (Any IntRep code)
| otherwise =
let
code dst = mkSeqInstr (LDI Q dst src)
in
- returnSUs (Any IntKind code)
+ returnUs (Any IntRep code)
where
src = ImmInt (fromInteger i)
let
code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
\begin{code}
-getAmode :: StixTree -> SUniqSM Amode
+getAmode :: StixTree -> UniqSM Amode
getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
getAmode (StPrim IntSubOp [x, StInt i]) =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg x `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg x `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnSUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i]) =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg x `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg x `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnSUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
getAmode leaf
| maybeToBool imm =
- returnSUs (Amode (AddrImm imm__2) id)
+ returnUs (Amode (AddrImm imm__2) id)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
getAmode other =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg other `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg other `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
in
- returnSUs (Amode (AddrReg reg) code)
+ returnUs (Amode (AddrReg reg) code)
\end{code}
\begin{code}
-getCallArg
+getCallArg
:: ([(Reg,Reg)],Int) -- Argument registers and stack offset (accumulator)
-> StixTree -- Current argument
- -> SUniqSM (([(Reg,Reg)],Int), CodeBlock AlphaInstr) -- Updated accumulator and code
+ -> UniqSM (([(Reg,Reg)],Int), CodeBlock AlphaInstr) -- Updated accumulator and code
-- We have to use up all of our argument registers first.
-getCallArg ((iDst,fDst):dsts, offset) arg =
- getReg arg `thenSUs` \ register ->
+getCallArg ((iDst,fDst):dsts, offset) arg =
+ getReg arg `thenUs` \ register ->
let
- reg = if isFloatingKind pk then fDst else iDst
+ reg = if isFloatingRep pk then fDst else iDst
code = registerCode register reg
src = registerName register reg
pk = registerKind register
in
- returnSUs (
- if isFloatingKind pk then
- ((dsts, offset), if isFixed register then
+ returnUs (
+ if isFloatingRep pk then
+ ((dsts, offset), if isFixed register then
code . mkSeqInstr (FMOV src fDst)
else code)
- else
- ((dsts, offset), if isFixed register then
+ else
+ ((dsts, offset), if isFixed register then
code . mkSeqInstr (OR src (RIReg src) iDst)
else code))
-- Once we have run out of argument registers, we move to the stack
-getCallArg ([], offset) arg =
- getReg arg `thenSUs` \ register ->
+getCallArg ([], offset) arg =
+ getReg arg `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
- let
+ `thenUs` \ tmp ->
+ let
code = registerCode register tmp
src = registerName register tmp
pk = registerKind register
sz = kindToSize pk
in
- returnSUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
+ returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
\end{code}
some of the register transfers will go away, because we can use the destination
register to complete the code generation for the right hand side. This only
fails when the right hand side is forced into a fixed register (e.g. the result
-of a call).
+of a call).
\begin{code}
-assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
+assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr)
assignIntCode pk (StInd _ dst) src =
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode dst `thenSUs` \ amode ->
- getReg src `thenSUs` \ register ->
- let
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getReg src `thenUs` \ register ->
+ let
code1 = amodeCode amode asmVoid
dst__2 = amodeAddr amode
code2 = registerCode register tmp asmVoid
sz = kindToSize pk
code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
in
- returnSUs code__2
+ returnUs code__2
assignIntCode pk dst src =
- getReg dst `thenSUs` \ register1 ->
- getReg src `thenSUs` \ register2 ->
- let
+ getReg dst `thenUs` \ register1 ->
+ getReg src `thenUs` \ register2 ->
+ let
dst__2 = registerName register1 zero
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
- code__2 = if isFixed register2 then
+ code__2 = if isFixed register2 then
code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
else code
in
- returnSUs code__2
+ returnUs code__2
-assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
+assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr)
assignFltCode pk (StInd _ dst) src =
- getNewRegNCG pk `thenSUs` \ tmp ->
- getAmode dst `thenSUs` \ amode ->
- getReg src `thenSUs` \ register ->
- let
+ getNewRegNCG pk `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getReg src `thenUs` \ register ->
+ let
code1 = amodeCode amode asmVoid
dst__2 = amodeAddr amode
code2 = registerCode register tmp asmVoid
sz = kindToSize pk
code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
in
- returnSUs code__2
+ returnUs code__2
assignFltCode pk dst src =
- getReg dst `thenSUs` \ register1 ->
- getReg src `thenSUs` \ register2 ->
- let
+ getReg dst `thenUs` \ register1 ->
+ getReg src `thenUs` \ register2 ->
+ let
dst__2 = registerName register1 zero
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
- code__2 = if isFixed register2 then
+ code__2 = if isFixed register2 then
code . mkSeqInstr (FMOV src__2 dst__2)
else code
in
- returnSUs code__2
+ returnUs code__2
-\end{code}
+\end{code}
Generating an unconditional branch. We accept two types of targets:
an immediate CLabel or a tree that gets evaluated into a register.
\begin{code}
-genJump
+genJump
:: StixTree -- the branch target
- -> SUniqSM (CodeBlock AlphaInstr)
+ -> UniqSM (CodeBlock AlphaInstr)
-genJump (StCLbl lbl)
+genJump (StCLbl lbl)
| isAsmTemp lbl = returnInstr (BR target)
| otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
where
target = ImmCLbl lbl
genJump tree =
- getReg tree `thenSUs` \ register ->
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getReg tree `thenUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
let
dst = registerName register pv
code = registerCode register pv
if isFixed register then
returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
else
- returnSUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
+ returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
\end{code}
Conditional jumps are always to local labels, so we can use
-branch instructions. We peek at the arguments to decide what kind
-of comparison to do. For comparisons with 0, we're laughing, because
-we can just do the desired conditional branch.
+branch instructions. We peek at the arguments to decide what kind
+of comparison to do. For comparisons with 0, we're laughing, because
+we can just do the desired conditional branch.
\begin{code}
-genCondJump
+genCondJump
:: CLabel -- the branch target
-> StixTree -- the condition on which to branch
- -> SUniqSM (CodeBlock AlphaInstr)
+ -> UniqSM (CodeBlock AlphaInstr)
genCondJump lbl (StPrim op [x, StInt 0]) =
- getReg x `thenSUs` \ register ->
+ getReg x `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
+ `thenUs` \ tmp ->
let
code = registerCode register tmp
value = registerName register tmp
pk = registerKind register
- target = ImmCLbl lbl
+ target = ImmCLbl lbl
in
returnSeq code [BI (cmpOp op) value target]
where
cmpOp AddrLeOp = EQ
genCondJump lbl (StPrim op [x, StDouble 0.0]) =
- getReg x `thenSUs` \ register ->
+ getReg x `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
+ `thenUs` \ tmp ->
let
code = registerCode register tmp
value = registerName register tmp
pk = registerKind register
- target = ImmCLbl lbl
+ target = ImmCLbl lbl
in
- returnSUs (code . mkSeqInstr (BF (cmpOp op) value target))
+ returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
where
cmpOp FloatGtOp = GT
cmpOp FloatGeOp = GE
cmpOp DoubleLtOp = LT
cmpOp DoubleLeOp = LE
-genCondJump lbl (StPrim op args)
+genCondJump lbl (StPrim op args)
| fltCmpOp op =
- trivialFCode instr args `thenSUs` \ register ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ trivialFCode instr args `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
code = registerCode register tmp
result = registerName register tmp
- target = ImmCLbl lbl
+ target = ImmCLbl lbl
in
- returnSUs (code . mkSeqInstr (BF cond result target))
+ returnUs (code . mkSeqInstr (BF cond result target))
where
fltCmpOp op = case op of
- FloatGtOp -> True
- FloatGeOp -> True
- FloatEqOp -> True
- FloatNeOp -> True
- FloatLtOp -> True
- FloatLeOp -> True
- DoubleGtOp -> True
- DoubleGeOp -> True
- DoubleEqOp -> True
- DoubleNeOp -> True
- DoubleLtOp -> True
- DoubleLeOp -> True
- _ -> False
+ FloatGtOp -> True
+ FloatGeOp -> True
+ FloatEqOp -> True
+ FloatNeOp -> True
+ FloatLtOp -> True
+ FloatLeOp -> True
+ DoubleGtOp -> True
+ DoubleGeOp -> True
+ DoubleEqOp -> True
+ DoubleNeOp -> True
+ DoubleLtOp -> True
+ DoubleLeOp -> True
+ _ -> False
(instr, cond) = case op of
- FloatGtOp -> (FCMP TF LE, EQ)
- FloatGeOp -> (FCMP TF LT, EQ)
- FloatEqOp -> (FCMP TF EQ, NE)
- FloatNeOp -> (FCMP TF EQ, EQ)
- FloatLtOp -> (FCMP TF LT, NE)
- FloatLeOp -> (FCMP TF LE, NE)
- DoubleGtOp -> (FCMP TF LE, EQ)
- DoubleGeOp -> (FCMP TF LT, EQ)
- DoubleEqOp -> (FCMP TF EQ, NE)
- DoubleNeOp -> (FCMP TF EQ, EQ)
- DoubleLtOp -> (FCMP TF LT, NE)
- DoubleLeOp -> (FCMP TF LE, NE)
+ FloatGtOp -> (FCMP TF LE, EQ)
+ FloatGeOp -> (FCMP TF LT, EQ)
+ FloatEqOp -> (FCMP TF EQ, NE)
+ FloatNeOp -> (FCMP TF EQ, EQ)
+ FloatLtOp -> (FCMP TF LT, NE)
+ FloatLeOp -> (FCMP TF LE, NE)
+ DoubleGtOp -> (FCMP TF LE, EQ)
+ DoubleGeOp -> (FCMP TF LT, EQ)
+ DoubleEqOp -> (FCMP TF EQ, NE)
+ DoubleNeOp -> (FCMP TF EQ, EQ)
+ DoubleLtOp -> (FCMP TF LT, NE)
+ DoubleLeOp -> (FCMP TF LE, NE)
genCondJump lbl (StPrim op args) =
- trivialCode instr args `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ trivialCode instr args `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
result = registerName register tmp
- target = ImmCLbl lbl
+ target = ImmCLbl lbl
in
- returnSUs (code . mkSeqInstr (BI cond result target))
+ returnUs (code . mkSeqInstr (BI cond result target))
where
(instr, cond) = case op of
- CharGtOp -> (CMP LE, EQ)
- CharGeOp -> (CMP LT, EQ)
- CharEqOp -> (CMP EQ, NE)
- CharNeOp -> (CMP EQ, EQ)
- CharLtOp -> (CMP LT, NE)
- CharLeOp -> (CMP LE, NE)
- IntGtOp -> (CMP LE, EQ)
- IntGeOp -> (CMP LT, EQ)
- IntEqOp -> (CMP EQ, NE)
- IntNeOp -> (CMP EQ, EQ)
- IntLtOp -> (CMP LT, NE)
- IntLeOp -> (CMP LE, NE)
- WordGtOp -> (CMP ULE, EQ)
- WordGeOp -> (CMP ULT, EQ)
- WordEqOp -> (CMP EQ, NE)
- WordNeOp -> (CMP EQ, EQ)
- WordLtOp -> (CMP ULT, NE)
- WordLeOp -> (CMP ULE, NE)
- AddrGtOp -> (CMP ULE, EQ)
- AddrGeOp -> (CMP ULT, EQ)
- AddrEqOp -> (CMP EQ, NE)
- AddrNeOp -> (CMP EQ, EQ)
- AddrLtOp -> (CMP ULT, NE)
- AddrLeOp -> (CMP ULE, NE)
+ CharGtOp -> (CMP LE, EQ)
+ CharGeOp -> (CMP LT, EQ)
+ CharEqOp -> (CMP EQ, NE)
+ CharNeOp -> (CMP EQ, EQ)
+ CharLtOp -> (CMP LT, NE)
+ CharLeOp -> (CMP LE, NE)
+ IntGtOp -> (CMP LE, EQ)
+ IntGeOp -> (CMP LT, EQ)
+ IntEqOp -> (CMP EQ, NE)
+ IntNeOp -> (CMP EQ, EQ)
+ IntLtOp -> (CMP LT, NE)
+ IntLeOp -> (CMP LE, NE)
+ WordGtOp -> (CMP ULE, EQ)
+ WordGeOp -> (CMP ULT, EQ)
+ WordEqOp -> (CMP EQ, NE)
+ WordNeOp -> (CMP EQ, EQ)
+ WordLtOp -> (CMP ULT, NE)
+ WordLeOp -> (CMP ULE, NE)
+ AddrGtOp -> (CMP ULE, EQ)
+ AddrGeOp -> (CMP ULT, EQ)
+ AddrEqOp -> (CMP EQ, NE)
+ AddrNeOp -> (CMP EQ, EQ)
+ AddrLtOp -> (CMP ULT, NE)
+ AddrLeOp -> (CMP ULE, NE)
\end{code}
genCCall
:: FAST_STRING -- function to call
- -> PrimKind -- type of the result
+ -> PrimRep -- type of the result
-> [StixTree] -- arguments (of mixed type)
- -> SUniqSM (CodeBlock AlphaInstr)
+ -> UniqSM (CodeBlock AlphaInstr)
genCCall fn kind args =
- mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
- `thenSUs` \ ((unused,_), argCode) ->
+ mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
+ `thenUs` \ ((unused,_), argCode) ->
let
nRegs = length argRegs - length unused
code = asmParThen (map ($ asmVoid) argCode)
in
returnSeq code [
LDA pv (AddrImm (ImmLab (uppPStr fn))),
- JSR ra (AddrReg pv) nRegs,
+ JSR ra (AddrReg pv) nRegs,
LDGP gp (AddrReg ra)]
where
- mapAccumLNCG f b [] = returnSUs (b, [])
- mapAccumLNCG f b (x:xs) =
- f b x `thenSUs` \ (b__2, x__2) ->
- mapAccumLNCG f b__2 xs `thenSUs` \ (b__3, xs__2) ->
- returnSUs (b__3, x__2:xs__2)
+ mapAccumLNCG f b [] = returnUs (b, [])
+ mapAccumLNCG f b (x:xs) =
+ f b x `thenUs` \ (b__2, x__2) ->
+ mapAccumLNCG f b__2 xs `thenUs` \ (b__3, xs__2) ->
+ returnUs (b__3, x__2:xs__2)
\end{code}
\begin{code}
-trivialCode
- :: (Reg -> RI -> Reg -> AlphaInstr)
+trivialCode
+ :: (Reg -> RI -> Reg -> AlphaInstr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialCode instr [x, StInt y]
| is8Bits y =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
trivialCode instr [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
code__2 dst = asmParThen [code1, code2] .
mkSeqInstr (instr src1 (RIReg src2) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-trivialFCode
- :: (Reg -> Reg -> Reg -> AlphaInstr)
- -> [StixTree]
- -> SUniqSM Register
+trivialFCode
+ :: (Reg -> Reg -> Reg -> AlphaInstr)
+ -> [StixTree]
+ -> UniqSM Register
trivialFCode instr [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp1 ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
let
code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
mkSeqInstr (instr src1 src2 dst)
in
- returnSUs (Any DoubleKind code__2)
+ returnUs (Any DoubleRep code__2)
\end{code}
Some bizarre special code for getting condition codes into registers.
Integer non-equality is a test for equality followed by an XOR with 1.
(Integer comparisons always set the result register to 0 or 1.) Floating
-point comparisons of any kind leave the result in a floating point register,
+point comparisons of any kind leave the result in a floating point register,
so we need to wrangle an integer register out of things.
\begin{code}
intNECode
:: [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
intNECode args =
- trivialCode (CMP EQ) args `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ trivialCode (CMP EQ) args `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-cmpFCode
- :: (Reg -> Reg -> Reg -> AlphaInstr)
+cmpFCode
+ :: (Reg -> Reg -> Reg -> AlphaInstr)
-> Cond
- -> [StixTree]
- -> SUniqSM Register
+ -> [StixTree]
+ -> UniqSM Register
cmpFCode instr cond args =
- trivialFCode instr args `thenSUs` \ register ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
- getUniqLabelNCG `thenSUs` \ lbl ->
+ trivialFCode instr args `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let
code = registerCode register tmp
result = registerName register tmp
OR zero (RIImm (ImmInt 1)) dst,
BF cond result (ImmCLbl lbl),
OR zero (RIReg zero) dst,
- LABEL lbl]
+ LABEL lbl]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
\begin{code}
-trivialUCode
- :: (RI -> Reg -> AlphaInstr)
+trivialUCode
+ :: (RI -> Reg -> AlphaInstr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialUCode instr [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-trivialUFCode
- :: (Reg -> Reg -> AlphaInstr)
+trivialUFCode
+ :: (Reg -> Reg -> AlphaInstr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialUFCode instr [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr src dst)
in
- returnSUs (Any DoubleKind code__2)
+ returnUs (Any DoubleRep code__2)
\end{code}
\begin{code}
-coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
+coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
coerceIntCode pk [x] =
- getReg x `thenSUs` \ register ->
+ getReg x `thenUs` \ register ->
case register of
- Fixed reg _ code -> returnSUs (Fixed reg pk code)
- Any _ code -> returnSUs (Any pk code)
+ Fixed reg _ code -> returnUs (Fixed reg pk code)
+ Any _ code -> returnUs (Any pk code)
-coerceFltCode :: [StixTree] -> SUniqSM Register
+coerceFltCode :: [StixTree] -> UniqSM Register
coerceFltCode [x] =
- getReg x `thenSUs` \ register ->
+ getReg x `thenUs` \ register ->
case register of
- Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code)
- Any _ code -> returnSUs (Any DoubleKind code)
+ Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
+ Any _ code -> returnUs (Any DoubleRep code)
\end{code}
-Integer to character conversion.
+Integer to character conversion.
\begin{code}
chrCode [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ reg ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
let
code = registerCode register reg
src = registerName register reg
code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
\begin{code}
-coerceInt2FP :: [StixTree] -> SUniqSM Register
-coerceInt2FP [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ reg ->
+coerceInt2FP :: [StixTree] -> UniqSM Register
+coerceInt2FP [x] =
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
let
code = registerCode register reg
src = registerName register reg
LD TF dst (spRel 0),
CVTxy Q TF dst dst]
in
- returnSUs (Any DoubleKind code__2)
+ returnUs (Any DoubleRep code__2)
-coerceFP2Int :: [StixTree] -> SUniqSM Register
+coerceFP2Int :: [StixTree] -> UniqSM Register
coerceFP2Int [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
ST TF tmp (spRel 0),
LD Q dst (spRel 0)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
is8Bits i = i >= -256 && i < 256
maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i)
+maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
| otherwise = Just (ImmInteger i)
maybeImm (StLitLbl s) = Just (ImmLab s)
mangleIndexTree :: StixTree -> StixTree
-mangleIndexTree (StIndex pk base (StInt i)) =
+mangleIndexTree (StIndex pk base (StInt i)) =
StPrim IntAddOp [base, off]
where
off = StInt (i * size pk)
- size :: PrimKind -> Integer
+ size :: PrimRep -> Integer
size pk = case kindToSize pk of
{B -> 1; BU -> 1; W -> 2; WU -> 2; L -> 4; FF -> 4; SF -> 4; _ -> 8}
-mangleIndexTree (StIndex pk base off) =
+mangleIndexTree (StIndex pk base off) =
case pk of
- CharKind -> StPrim IntAddOp [base, off]
+ CharRep -> StPrim IntAddOp [base, off]
_ -> StPrim IntAddOp [base, off__2]
where
off__2 = StPrim SllOp [off, StInt 3]
cvtLitLit "stdin" = "_iob+0" -- This one is probably okay...
cvtLitLit "stdout" = "_iob+56" -- but these next two are dodgy at best
cvtLitLit "stderr" = "_iob+112"
-cvtLitLit s
+cvtLitLit s
| isHex s = s
| otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
- where
+ where
isHex ('0':'x':xs) = all isHexDigit xs
isHex _ = False
-- Now, where have I seen this before?
\begin{code}
-spRel
+spRel
:: Int -- desired stack offset in words, positive or negative
-> Addr
spRel n = AddrRegImm sp (ImmInt (n * 8))
\begin{code}
-getNewRegNCG :: PrimKind -> SUniqSM Reg
-getNewRegNCG pk =
- getSUnique `thenSUs` \ u ->
- returnSUs (mkReg u pk)
+getNewRegNCG :: PrimRep -> UniqSM Reg
+getNewRegNCG pk =
+ getUnique `thenUs` \ u ->
+ returnUs (mkReg u pk)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AsmCodeGen where
-import AbsCSyn(AbstractC)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import Stdio(_FILE)
-data AbstractC
-data GlobalSwitch
-data SwitchResult
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply
-dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> SplitUniqSupply -> [Char]
-writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> SplitUniqSupply -> _State _RealWorld -> ((), _State _RealWorld)
-
#include "../../includes/GhcConstants.h"
module AsmCodeGen (
-#ifdef __GLASGOW_HASKELL__
writeRealAsm,
-#endif
dumpRealAsm,
-- And, I guess we need these...
AbstractC, GlobalSwitch, SwitchResult,
- SplitUniqSupply, SUniqSM(..)
+ UniqSupply, UniqSM(..)
) where
import AbsCSyn ( AbstractC )
import AbsCStixGen ( genCodeAbstractC )
-import AbsPrel ( PrimKind, PrimOp(..)
+import PrelInfo ( PrimRep, PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import SparcDesc ( mkSparc )
#endif
import Stix
-import SplitUniq
-import Unique
+import UniqSupply
import Unpretty
import Util
-#if defined(__HBC__)
-import
- Word
-#endif
\end{code}
This is a generic assembly language generator for the Glasgow Haskell
with a Twig-like system handling each statement in turn.
\item A scheduler turns the tree of assembly language orderings
into a sequence suitable for input to an assembler.
-\end{itemize}
+\end{itemize}
The @codeGenerate@ function returns the final assembly language output
(as a String). We can return a string, because there is only one way
of printing the output suitable for assembler consumption. It also
(ref), but also draws concepts from (ref). The basic idea is to
(dynamically) walk the Abstract C syntax tree, annotating it with
possible code matches. For example, on the Sparc, a possible match
-(with its translation) could be
-@
- :=
- / \
- i r2 => ST r2,[r1]
+(with its translation) could be
+@
+ :=
+ / \
+ i r2 => ST r2,[r1]
|
- r1
+ r1
@
where @r1,r2@ are registers, and @i@ is an indirection. The Twig
bit twiddling algorithm for tree matching has been abandoned. It is
the choices below.
\begin{code}
-
-#ifdef __GLASGOW_HASKELL__
-# if __GLASGOW_HASKELL__ < 23
-# define _FILE _Addr
-# endif
-writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> SplitUniqSupply -> PrimIO ()
+writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> UniqSupply -> PrimIO ()
writeRealAsm flags file absC uniq_supply
= uppAppendFile file 80 (runNCG (code flags absC) uniq_supply)
-#endif
-
-dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> SplitUniqSupply -> String
+dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> UniqSupply -> String
dumpRealAsm flags absC uniq_supply = uppShow 80 (runNCG (code flags absC) uniq_supply)
runNCG m uniq_supply = m uniq_supply
code flags absC =
- genCodeAbstractC target absC `thenSUs` \ treelists ->
- let
+ genCodeAbstractC target absC `thenUs` \ treelists ->
+ let
stix = map (map (genericOpt target)) treelists
in
codeGen {-target-} sty stix
Just _ {-???"sparc-sun-solaris2"-} -> mkSparc False flags
# endif
#endif
- _ -> error
+ _ -> error
("ERROR:Trying to generate assembly language for an unsupported architecture\n"++
"(or one for which this build is not configured).")
\begin{code}
-genericOpt
- :: Target
- -> StixTree
+genericOpt
+ :: Target
+ -> StixTree
-> StixTree
\end{code}
genericOpt target (StIndex pk (StIndex pk' base off) off')
| pk == pk' =
- StIndex pk (genericOpt target base)
+ StIndex pk (genericOpt target base)
(genericOpt target (StPrim IntAddOp [off, off']))
genericOpt target (StIndex pk base off) =
- StIndex pk (genericOpt target base)
+ StIndex pk (genericOpt target base)
(genericOpt target off)
\end{code}
\begin{code}
-genericOpt target leaf@(StReg (StixMagicId id)) =
- case stgReg target id of
+genericOpt target leaf@(StReg (StixMagicId id)) =
+ case stgReg target id of
Always tree -> genericOpt target tree
Save _ -> leaf
IntAbsOp -> StInt (abs x)
_ -> StPrim op arg
-primOpt op args@[StInt x, StInt y] =
+primOpt op args@[StInt x, StInt y] =
case op of
CharGtOp -> StInt (if x > y then 1 else 0)
CharGeOp -> StInt (if x >= y then 1 else 0)
also assume that constants have been shifted to the right when possible.
\begin{code}
-
-primOpt op [x@(StInt _), y] | commutableOp op = primOpt op [y, x]
---OLD:
---primOpt op [x@(StDouble _), y] | commutableOp op = primOpt op [y, x]
-
+primOpt op [x@(StInt _), y] | commutableOp op = primOpt op [y, x]
\end{code}
We can often do something with constants of 0 and 1 ...
\begin{code}
-
-primOpt op args@[x, y@(StInt 0)] =
+primOpt op args@[x, y@(StInt 0)] =
case op of
IntAddOp -> x
IntSubOp -> x
ISrlOp -> x
_ -> StPrim op args
-primOpt op args@[x, y@(StInt 1)] =
+primOpt op args@[x, y@(StInt 1)] =
case op of
IntMulOp -> x
IntQuotOp -> x
IntRemOp -> StInt 0
_ -> StPrim op args
-
--- The following code tweaks a bug in early versions of GHC (pre-0.21)
-
-{- OLD: (death to constant folding in ncg)
-primOpt op args@[x, y@(StDouble 0.0)] =
- case op of
- FloatAddOp -> x
- FloatSubOp -> x
- FloatMulOp -> y
- DoubleAddOp -> x
- DoubleSubOp -> x
- DoubleMulOp -> y
- _ -> StPrim op args
-
-primOpt op args@[x, y@(StDouble 1.0)] =
- case op of
- FloatMulOp -> x
- FloatDivOp -> x
- DoubleMulOp -> x
- DoubleDivOp -> x
- _ -> StPrim op args
-
-primOpt op args@[x, y@(StDouble 2.0)] =
- case op of
- FloatMulOp -> StPrim FloatAddOp [x, x]
- DoubleMulOp -> StPrim DoubleAddOp [x, x]
- _ -> StPrim op args
--}
-
\end{code}
Now look for multiplication/division by powers of 2 (integers).
\begin{code}
-
-primOpt op args@[x, y@(StInt n)] =
+primOpt op args@[x, y@(StInt n)] =
case op of
IntMulOp -> case exact_log2 n of
- Nothing -> StPrim op args
+ Nothing -> StPrim op args
Just p -> StPrim SllOp [x, StInt p]
IntQuotOp -> case exact_log2 n of
- Nothing -> StPrim op args
+ Nothing -> StPrim op args
Just p -> StPrim SraOp [x, StInt p]
_ -> StPrim op args
-
\end{code}
Anything else is just too hard.
\begin{code}
-
primOpt op args = StPrim op args
-
\end{code}
-The commutable ops are those for which we will try to move constants to the
-right hand side for strength reduction.
+The commutable ops are those for which we will try to move constants
+to the right hand side for strength reduction.
\begin{code}
-
commutableOp :: PrimOp -> Bool
+
commutableOp CharEqOp = True
commutableOp CharNeOp = True
commutableOp IntAddOp = True
commutableOp DoubleEqOp = True
commutableOp DoubleNeOp = True
commutableOp _ = False
-
\end{code}
-This algorithm for determining the $\log_2$ of exact powers of 2 comes from gcc. It
-requires bit manipulation primitives, so we have a ghc version and an hbc version.
-Other Haskell compilers are on their own.
+This algorithm for determining the $\log_2$ of exact powers of 2 comes
+from gcc. It requires bit manipulation primitives, so we have a ghc
+version and an hbc version. Other Haskell compilers are on their own.
\begin{code}
-
-#ifdef __GLASGOW_HASKELL__
-
w2i x = word2Int# x
i2w x = int2Word# x
i2w_s x = (x::Int#)
exact_log2 :: Integer -> Maybe Integer
-exact_log2 x
+exact_log2 x
| x <= 0 || x >= 2147483648 = Nothing
| otherwise = case fromInteger x of
- I# x# -> if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then Nothing
+ I# x# -> if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then Nothing
else Just (toInteger (I# (pow2 x#)))
where pow2 x# | x# ==# 1# = 0#
| otherwise = 1# +# pow2 (w2i (i2w x# `shiftr` i2w_s 1#))
-# if __GLASGOW_HASKELL__ >= 23
shiftr x y = shiftRA# x y
-# else
- shiftr x y = shiftR# x y
-# endif
-
-#else {-probably HBC-}
-
-exact_log2 :: Integer -> Maybe Integer
-exact_log2 x
- | x <= 0 || x >= 2147483648 = Nothing
- | otherwise =
- if x' `bitAnd` (-x') /= x' then Nothing
- else Just (toInteger (pow2 x'))
-
- where x' = ((fromInteger x) :: Word)
- pow2 x | x == bit0 = 0 :: Int
- | otherwise = 1 + pow2 (x `bitRsh` 1)
-
-#endif {-probably HBC-}
-
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AsmRegAlloc where
-import CLabelInfo(CLabel)
-import FiniteMap(FiniteMap)
-import OrdList(OrdList)
-import Outputable(NamedThing, Outputable)
-import PrimKind(PrimKind)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-class MachineCode a where
- regUsage :: a -> RegUsage
- regLiveness :: a -> RegLiveness -> RegLiveness
- patchRegs :: a -> (Reg -> Reg) -> a
- spillReg :: Reg -> Reg -> OrdList a
- loadReg :: Reg -> Reg -> OrdList a
-class MachineRegisters a where
- mkMRegs :: [Int] -> a
- possibleMRegs :: PrimKind -> a -> [Int]
- useMReg :: a -> Int# -> a
- useMRegs :: a -> [Int] -> a
- freeMReg :: a -> Int# -> a
- freeMRegs :: a -> [Int] -> a
-data CLabel
-data FiniteMap a b
-data FutureLive = FL (UniqFM Reg) (FiniteMap CLabel (UniqFM Reg))
-data OrdList a
-data PrimKind
-data Reg = FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind
-data RegLiveness = RL (UniqFM Reg) FutureLive
-data RegUsage = RU (UniqFM Reg) (UniqFM Reg)
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-extractMappedRegNos :: [Reg] -> [Int]
-mkReg :: Unique -> PrimKind -> Reg
-runHairyRegAllocate :: (MachineRegisters a, MachineCode b) => a -> [Int] -> OrdList b -> [b]
-runRegAllocate :: (MachineRegisters a, MachineCode b) => a -> [Int] -> OrdList b -> [b]
-instance Eq Reg
-instance Ord Reg
-instance NamedThing Reg
-instance Outputable Reg
-instance Text Reg
-
MachineRegisters(..), MachineCode(..),
mkReg, runRegAllocate, runHairyRegAllocate,
- extractMappedRegNos,
+ extractMappedRegNos
-- And, for self-sufficiency
- CLabel, OrdList, PrimKind, UniqSet(..), UniqFM,
- FiniteMap, Unique
) where
-IMPORT_Trace
-
-import CLabelInfo ( CLabel )
+import CLabel ( CLabel )
import FiniteMap
import MachDesc
import Maybes ( maybeToBool, Maybe(..) )
import OrdList -- ( mkUnitList, mkSeqList, mkParList, OrdList )
import Outputable
import Pretty
-import PrimKind ( PrimKind(..) )
import UniqSet
-import Unique
+import Unique ( Unique )
import Util
#if ! OMIT_NATIVE_CODEGEN
| MappedReg FAST_INT -- A dynamically allocated machine register
- | MemoryReg Int PrimKind -- A machine "register" actually held in a memory
+ | MemoryReg Int PrimRep -- A machine "register" actually held in a memory
-- allocated table of registers which didn't fit
-- in real registers.
- | UnmappedReg Unique PrimKind -- One of an infinite supply of registers,
+ | UnmappedReg Unique PrimRep -- One of an infinite supply of registers,
-- always mapped to one of the earlier two
-- before we're done.
-- No thanks: deriving (Eq)
-mkReg :: Unique -> PrimKind -> Reg
+mkReg :: Unique -> PrimRep -> Reg
mkReg = UnmappedReg
instance Text Reg where
cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i'
cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i'
-cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmpUnique u u'
+cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmp u u'
cmpReg r1 r2 =
let tag1 = tagReg r1
tag2 = tagReg r2
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 }
-#ifdef __GLASGOW_HASKELL__
_tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
instance NamedThing Reg where
- -- the *only* method that should be defined is "getTheUnique"!
+ -- the *only* method that should be defined is "getItsUnique"!
-- (so we can use UniqFMs/UniqSets on Regs
- getTheUnique (UnmappedReg u _) = u
- getTheUnique (FixedReg i) = mkPseudoUnique1 IBOX(i)
- getTheUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
- getTheUnique (MemoryReg i _) = mkPseudoUnique3 i
+ getItsUnique (UnmappedReg u _) = u
+ getItsUnique (FixedReg i) = mkPseudoUnique1 IBOX(i)
+ getItsUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
+ getItsUnique (MemoryReg i _) = mkPseudoUnique3 i
\end{code}
This is the generic register allocator.
class MachineRegisters a where
mkMRegs :: [Int] -> a
- possibleMRegs :: PrimKind -> a -> [Int]
+ possibleMRegs :: PrimRep -> a -> [Int]
useMReg :: a -> FAST_INT -> a
useMRegs :: a -> [Int] -> a
freeMReg :: a -> FAST_INT -> a
FutureLive
class MachineCode a where
--- OLD:
--- flatten :: OrdList a -> [a]
regUsage :: a -> RegUsage
regLiveness :: a -> RegLiveness -> RegLiveness
patchRegs :: a -> (Reg -> Reg) -> a
spillReg :: Reg -> Reg -> OrdList a
loadReg :: Reg -> Reg -> OrdList a
-
\end{code}
First we try something extremely simple.
If that fails, we have to do things the hard way.
\begin{code}
-
runRegAllocate
:: (MachineRegisters a, MachineCode b)
=> a
-> [b]
runRegAllocate regs reserve_regs instrs =
- case simpleAlloc of
+ case simpleAlloc of
Just x -> x
Nothing -> hairyAlloc
where
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface I386Code where
-import AbsCSyn(MagicId)
-import AsmRegAlloc(MachineCode, MachineRegisters, Reg)
-import BitSet(BitSet)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import FiniteMap(FiniteMap)
-import Maybes(Labda)
-import OrdList(OrdList)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import Stix(CodeSegment)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Addr = Addr (Labda Reg) (Labda (Reg, Int)) Imm | ImmAddr Imm Int
-type Base = Labda Reg
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data Reg {-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-}
-data BitSet {-# GHC_PRAGMA MkBS Word# #-}
-data CLabel
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data CodeSegment {-# GHC_PRAGMA DataSegment | TextSegment #-}
-data Cond = ALWAYS | GEU | LU | EQ | GT | GE | GU | LT | LE | LEU | NE | NEG | POS
-type Displacement = Imm
-data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-type I386Code = OrdList I386Instr
-data I386Instr
- = MOV Size Operand Operand | MOVZX Size Operand Operand | MOVSX Size Operand Operand | LEA Size Operand Operand | ADD Size Operand Operand | SUB Size Operand Operand | IMUL Size Operand Operand | IDIV Size Operand | AND Size Operand Operand | OR Size Operand Operand | XOR Size Operand Operand | NOT Size Operand | NEGI Size Operand | SHL Size Operand Operand | SAR Size Operand Operand | SHR Size Operand Operand | NOP | SAHF | FABS | FADD Size Operand | FADDP | FIADD Size Addr | FCHS | FCOM Size Operand | FCOS | FDIV Size Operand | FDIVP | FIDIV Size Addr | FDIVR Size Operand | FDIVRP | FIDIVR Size Addr | FICOM Size Addr | FILD Size Addr Reg | FIST Size Addr | FLD Size Operand | FLD1 | FLDZ | FMUL Size Operand | FMULP | FIMUL Size Addr | FRNDINT | FSIN | FSQRT | FST Size Operand | FSTP Size Operand | FSUB Size Operand | FSUBP | FISUB Size Addr | FSUBR Size Operand | FSUBRP | FISUBR Size Addr | FTST | FCOMP Size Operand | FUCOMPP | FXCH | FNSTSW | FNOP | TEST Size Operand Operand | CMP Size Operand Operand | SETCC Cond Operand | PUSH Size Operand | POP Size Operand | JMP Operand | JXX Cond CLabel | CALL Imm | CLTD | LABEL CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm]
-data I386Regs {-# GHC_PRAGMA SRegs BitSet BitSet #-}
-data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq | ImmLit CSeq
-type Index = Labda (Reg, Int)
-data Operand = OpReg Reg | OpImm Imm | OpAddr Addr
-data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data Size = B | HB | S | L | F | D
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-baseRegOffset :: MagicId -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-callerSaves :: MagicId -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 21 \ (u0 :: MagicId) -> case u0 of { _ALG_ _ORIG_ AbsCSyn Hp -> _!_ True [] []; (u1 :: MagicId) -> _!_ False [] [] } _N_ #-}
-eax :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [0#] _N_ #-}
-ebp :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [6#] _N_ #-}
-ebx :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [1#] _N_ #-}
-ecx :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [2#] _N_ #-}
-edi :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [5#] _N_ #-}
-edx :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [3#] _N_ #-}
-esi :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [4#] _N_ #-}
-esp :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [7#] _N_ #-}
-freeRegs :: [Reg]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
-is13Bits :: Integral a => a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(LU(U(ALASAAAA)AAA)AAAAAAAAAA)" {_A_ 3 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Integer ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(PPP)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
-kindToSize :: PrimKind -> Size
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
-offset :: Addr -> Int -> Labda Addr
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
-printLabeledCodes :: PprStyle -> [I386Instr] -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
-reservedRegs :: [Int]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [Int] [] _N_ #-}
-spRel :: Int -> Addr
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
-st0 :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
-st1 :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
-stgRegMap :: MagicId -> Labda Reg
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-strImmLit :: [Char] -> Imm
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
-instance MachineCode I386Instr
- {-# GHC_PRAGMA _M_ I386Code {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(I386Instr -> RegUsage), (I386Instr -> RegLiveness -> RegLiveness), (I386Instr -> (Reg -> Reg) -> I386Instr), (Reg -> Reg -> OrdList I386Instr), (Reg -> Reg -> OrdList I386Instr)] [_CONSTM_ MachineCode regUsage (I386Instr), _CONSTM_ MachineCode regLiveness (I386Instr), _CONSTM_ MachineCode patchRegs (I386Instr), _CONSTM_ MachineCode spillReg (I386Instr), _CONSTM_ MachineCode loadReg (I386Instr)] _N_
- regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_,
- patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_,
- spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_,
- loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
-instance MachineRegisters I386Regs
- {-# GHC_PRAGMA _M_ I386Code {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> I386Regs), (PrimKind -> I386Regs -> [Int]), (I386Regs -> Int# -> I386Regs), (I386Regs -> [Int] -> I386Regs), (I386Regs -> Int# -> I386Regs), (I386Regs -> [Int] -> I386Regs)] [_CONSTM_ MachineRegisters mkMRegs (I386Regs), _CONSTM_ MachineRegisters possibleMRegs (I386Regs), _CONSTM_ MachineRegisters useMReg (I386Regs), _CONSTM_ MachineRegisters useMRegs (I386Regs), _CONSTM_ MachineRegisters freeMReg (I386Regs), _CONSTM_ MachineRegisters freeMRegs (I386Regs)] _N_
- mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_,
- possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LL)" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_,
- useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_,
- useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_,
- freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_,
- freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-
#include "HsVersions.h"
module I386Code (
- Addr(..),
- Cond(..), Imm(..), Operand(..), Size(..),
- Base(..), Index(..), Displacement(..),
+ Addr(..),
+ Cond(..), Imm(..), Operand(..), Size(..),
+ Base(..), Index(..), Displacement(..),
I386Code(..),I386Instr(..),I386Regs,
- strImmLit, --UNUSED: strImmLab,
- spRel,
+ strImmLit,
+ spRel,
printLabeledCodes,
st0, st1, eax, ebx, ecx, edx, esi, edi, ebp, esp,
- freeRegs, reservedRegs,
+ freeRegs, reservedRegs
-- and, for self-sufficiency ...
- CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..),
- UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet
) where
-IMPORT_Trace
-
import AbsCSyn ( MagicId(..) )
import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..),
Reg(..), RegUsage(..), RegLiveness(..)
)
-import BitSet
+import BitSet
import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
-import CLabelInfo ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
-import FiniteMap
+import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
+import FiniteMap
import Maybes ( Maybe(..), maybeToBool )
import OrdList ( OrdList, mkUnitList, flattenOrdList )
-import Outputable
-import PrimKind ( PrimKind(..) )
+import Outputable
import UniqSet
import Stix
import Unpretty
| ImmLit Unpretty -- Simple string
deriving ()
---UNUSED:strImmLab s = ImmLab (uppStr s)
strImmLit s = ImmLit (uppStr s)
data Cond = ALWAYS
deriving ()
data Operand = OpReg Reg -- register
- | OpImm Imm -- immediate value
- | OpAddr Addr -- memory reference
+ | OpImm Imm -- immediate value
+ | OpAddr Addr -- memory reference
deriving ()
data Addr = Addr Base Index Displacement
- | ImmAddr Imm Int
- -- deriving Eq
+ | ImmAddr Imm Int
+ -- deriving Eq
type Base = Maybe Reg
type Index = Maybe (Reg, Int) -- Int is 2, 4 or 8
-- Moves.
- MOV Size Operand Operand
+ MOV Size Operand Operand
| MOVZX Size Operand Operand -- size is the size of operand 2
| MOVSX Size Operand Operand -- size is the size of operand 2
-- Load effective address (also a very useful three-operand add instruction :-)
- | LEA Size Operand Operand
+ | LEA Size Operand Operand
-- Int Arithmetic.
- | ADD Size Operand Operand
- | SUB Size Operand Operand
+ | ADD Size Operand Operand
+ | SUB Size Operand Operand
-- Multiplication (signed and unsigned), Division (signed and unsigned),
-- result in %eax, %edx.
-- Simple bit-twiddling.
- | AND Size Operand Operand
- | OR Size Operand Operand
- | XOR Size Operand Operand
- | NOT Size Operand
+ | AND Size Operand Operand
+ | OR Size Operand Operand
+ | XOR Size Operand Operand
+ | NOT Size Operand
| NEGI Size Operand -- NEG instruction (name clash with Cond)
| SHL Size Operand Operand -- 1st operand must be an Imm
| SAR Size Operand Operand -- 1st operand must be an Imm
| SHR Size Operand Operand -- 1st operand must be an Imm
- | NOP
+ | NOP
-- Float Arithmetic. -- ToDo for 386
-- right up until we spit them out.
| SAHF -- stores ah into flags
- | FABS
+ | FABS
| FADD Size Operand -- src
- | FADDP
+ | FADDP
| FIADD Size Addr -- src
- | FCHS
+ | FCHS
| FCOM Size Operand -- src
- | FCOS
+ | FCOS
| FDIV Size Operand -- src
- | FDIVP
+ | FDIVP
| FIDIV Size Addr -- src
| FDIVR Size Operand -- src
- | FDIVRP
+ | FDIVRP
| FIDIVR Size Addr -- src
| FICOM Size Addr -- src
| FILD Size Addr Reg -- src, dst
| FIST Size Addr -- dst
| FLD Size Operand -- src
- | FLD1
- | FLDZ
+ | FLD1
+ | FLDZ
| FMUL Size Operand -- src
- | FMULP
+ | FMULP
| FIMUL Size Addr -- src
- | FRNDINT
- | FSIN
- | FSQRT
+ | FRNDINT
+ | FSIN
+ | FSQRT
| FST Size Operand -- dst
| FSTP Size Operand -- dst
| FSUB Size Operand -- src
- | FSUBP
+ | FSUBP
| FISUB Size Addr -- src
| FSUBR Size Operand -- src
- | FSUBRP
+ | FSUBRP
| FISUBR Size Addr -- src
- | FTST
+ | FTST
| FCOMP Size Operand -- src
- | FUCOMPP
+ | FUCOMPP
| FXCH
| FNSTSW
| FNOP
-- Comparison
-
- | TEST Size Operand Operand
- | CMP Size Operand Operand
- | SETCC Cond Operand
+
+ | TEST Size Operand Operand
+ | CMP Size Operand Operand
+ | SETCC Cond Operand
-- Stack Operations.
- | PUSH Size Operand
- | POP Size Operand
+ | PUSH Size Operand
+ | POP Size Operand
-- Jumping around.
| JMP Operand -- target
| JXX Cond CLabel -- target
- | CALL Imm
+ | CALL Imm
-- Other things.
- | CLTD -- sign extend %eax into %edx:%eax
+ | CLTD -- sign extend %eax into %edx:%eax
-- Pseudo-ops.
pprI386Reg :: Size -> FAST_INT -> Unpretty
pprI386Reg B i = uppPStr
(case i of {
- ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl");
+ ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl");
ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl");
_ -> SLIT("very naughty I386 byte register")
})
pprI386Reg HB i = uppPStr
(case i of {
- ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh");
+ ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh");
ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh");
_ -> SLIT("very naughty I386 high byte register")
})
pprI386Reg S i = uppPStr
(case i of {
- ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx");
+ ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx");
ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx");
- ILIT( 4) -> SLIT("%si"); ILIT( 5) -> SLIT("%di");
+ ILIT( 4) -> SLIT("%si"); ILIT( 5) -> SLIT("%di");
ILIT( 6) -> SLIT("%bp"); ILIT( 7) -> SLIT("%sp");
_ -> SLIT("very naughty I386 word register")
})
pprI386Reg L i = uppPStr
(case i of {
- ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx");
+ ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx");
ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx");
- ILIT( 4) -> SLIT("%esi"); ILIT( 5) -> SLIT("%edi");
+ ILIT( 4) -> SLIT("%esi"); ILIT( 5) -> SLIT("%edi");
ILIT( 6) -> SLIT("%ebp"); ILIT( 7) -> SLIT("%esp");
_ -> SLIT("very naughty I386 double word register")
})
pprI386Reg F i = uppPStr
(case i of {
--ToDo: rm these
- ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
+ ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
- ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
+ ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
_ -> SLIT("very naughty I386 float register")
})
pprI386Reg D i = uppPStr
(case i of {
--ToDo: rm these
- ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
+ ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
- ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
+ ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
_ -> SLIT("very naughty I386 float register")
})
LEU -> SLIT("be"); NE -> SLIT("ne");
NEG -> SLIT("s"); POS -> SLIT("ns");
ALWAYS -> SLIT("mp"); -- hack
- _ -> error "Spix: iI386Code: unknown conditional!"
+ _ -> error "Spix: iI386Code: unknown conditional!"
})
pprDollImm :: PprStyle -> Imm -> Unpretty
pprAddr :: PprStyle -> Addr -> Unpretty
pprAddr sty (ImmAddr imm off)
= uppBesides [pprImm sty imm,
- if off > 0 then uppChar '+' else uppPStr SLIT(""),
- if off == 0 then uppPStr SLIT("") else uppInt off
- ]
+ if off > 0 then uppChar '+' else uppPStr SLIT(""),
+ if off == 0 then uppPStr SLIT("") else uppInt off
+ ]
pprAddr sty (Addr Nothing Nothing displacement)
= uppBesides [pprDisp sty displacement]
pprAddr sty (Addr base index displacement)
= uppBesides [pprDisp sty displacement,
- uppChar '(',
- pprBase base,
- pprIndex index,
- uppChar ')'
- ]
+ uppChar '(',
+ pprBase base,
+ pprIndex index,
+ uppChar ')'
+ ]
where
pprBase (Just r) = uppBesides [pprReg L r,
- case index of
- Nothing -> uppPStr SLIT("")
- _ -> uppChar ','
- ]
+ case index of
+ Nothing -> uppPStr SLIT("")
+ _ -> uppChar ','
+ ]
pprBase _ = uppPStr SLIT("")
pprIndex (Just (r,i)) = uppBesides [pprReg L r, uppChar ',', uppInt i]
pprIndex _ = uppPStr SLIT("")
(case x of
B -> SLIT("b")
HB -> SLIT("b")
- S -> SLIT("w")
+ S -> SLIT("w")
L -> SLIT("l")
F -> SLIT("s")
D -> SLIT("l")
uppChar ' ',
pprAddr sty op,
uppComma,
- pprReg size dst
+ pprReg size dst
]
pprOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty
pprI386Instr sty (MOV size (OpReg src) (OpReg dst)) -- hack
| src == dst
= uppPStr SLIT("")
-pprI386Instr sty (MOV size src dst)
+pprI386Instr sty (MOV size src dst)
= pprSizeOpOp sty SLIT("mov") size src dst
pprI386Instr sty (MOVZX size src dst) = pprSizeOpOpCoerce sty SLIT("movzx") L size src dst
pprI386Instr sty (MOVSX size src dst) = pprSizeOpOpCoerce sty SLIT("movxs") L size src dst
-- here we do some patching, since the physical registers are only set late
-- in the code generation.
-pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
+pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
| reg1 == reg3
= pprSizeOpOp sty SLIT("add") size (OpReg reg2) dst
-pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
+pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
| reg2 == reg3
= pprSizeOpOp sty SLIT("add") size (OpReg reg1) dst
-pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
+pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
| reg1 == reg3
= pprI386Instr sty (ADD size (OpImm displ) dst)
pprI386Instr sty (LEA size src dst) = pprSizeOpOp sty SLIT("lea") size src dst
-pprI386Instr sty (ADD size (OpImm (ImmInt (-1))) dst)
+pprI386Instr sty (ADD size (OpImm (ImmInt (-1))) dst)
= pprSizeOp sty SLIT("dec") size dst
-pprI386Instr sty (ADD size (OpImm (ImmInt 1)) dst)
+pprI386Instr sty (ADD size (OpImm (ImmInt 1)) dst)
= pprSizeOp sty SLIT("inc") size dst
-pprI386Instr sty (ADD size src dst)
+pprI386Instr sty (ADD size src dst)
= pprSizeOpOp sty SLIT("add") size src dst
pprI386Instr sty (SUB size src dst) = pprSizeOpOp sty SLIT("sub") size src dst
pprI386Instr sty (IMUL size op1 op2) = pprSizeOpOp sty SLIT("imul") size op1 op2
pprI386Instr sty SAHF = uppPStr SLIT("\tsahf")
pprI386Instr sty FABS = uppPStr SLIT("\tfabs")
-pprI386Instr sty (FADD sz src@(OpAddr _))
+pprI386Instr sty (FADD sz src@(OpAddr _))
= uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppChar ' ', pprOperand sty sz src]
-pprI386Instr sty (FADD sz src)
+pprI386Instr sty (FADD sz src)
= uppPStr SLIT("\tfadd")
-pprI386Instr sty FADDP
+pprI386Instr sty FADDP
= uppPStr SLIT("\tfaddp")
-pprI386Instr sty (FMUL sz src)
+pprI386Instr sty (FMUL sz src)
= uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppChar ' ', pprOperand sty sz src]
-pprI386Instr sty FMULP
+pprI386Instr sty FMULP
= uppPStr SLIT("\tfmulp")
pprI386Instr sty (FIADD size op) = pprSizeAddr sty SLIT("fiadd") size op
pprI386Instr sty FCHS = uppPStr SLIT("\tfchs")
pprI386Instr sty (FCOM size op) = pprSizeOp sty SLIT("fcom") size op
pprI386Instr sty FCOS = uppPStr SLIT("\tfcos")
pprI386Instr sty (FIDIV size op) = pprSizeAddr sty SLIT("fidiv") size op
-pprI386Instr sty (FDIV sz src)
+pprI386Instr sty (FDIV sz src)
= uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppChar ' ', pprOperand sty sz src]
pprI386Instr sty FDIVP
= uppPStr SLIT("\tfdivp")
pprI386Instr sty (FICOM size op) = pprSizeAddr sty SLIT("ficom") size op
pprI386Instr sty (FILD sz op reg) = pprSizeAddrReg sty SLIT("fild") sz op reg
pprI386Instr sty (FIST size op) = pprSizeAddr sty SLIT("fist") size op
-pprI386Instr sty (FLD sz (OpImm (ImmCLbl src)))
+pprI386Instr sty (FLD sz (OpImm (ImmCLbl src)))
= uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprCLabel sty src]
-pprI386Instr sty (FLD sz src)
+pprI386Instr sty (FLD sz src)
= uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprOperand sty sz src]
pprI386Instr sty FLD1 = uppPStr SLIT("\tfld1")
pprI386Instr sty FLDZ = uppPStr SLIT("\tfldz")
pprI386Instr sty FRNDINT = uppPStr SLIT("\tfrndint")
pprI386Instr sty FSIN = uppPStr SLIT("\tfsin")
pprI386Instr sty FSQRT = uppPStr SLIT("\tfsqrt")
-pprI386Instr sty (FST sz dst)
+pprI386Instr sty (FST sz dst)
= uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
-pprI386Instr sty (FSTP sz dst)
+pprI386Instr sty (FSTP sz dst)
= uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
pprI386Instr sty (FISUB size op) = pprSizeAddr sty SLIT("fisub") size op
-pprI386Instr sty (FSUB sz src)
+pprI386Instr sty (FSUB sz src)
= uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppChar ' ', pprOperand sty sz src]
pprI386Instr sty FSUBP
= uppPStr SLIT("\tfsubp")
= pprSizeOp sty SLIT("fsubr") size src
pprI386Instr sty FSUBRP
= uppPStr SLIT("\tfsubpr")
-pprI386Instr sty (FISUBR size op)
+pprI386Instr sty (FISUBR size op)
= pprSizeAddr sty SLIT("fisubr") size op
pprI386Instr sty FTST = uppPStr SLIT("\tftst")
-pprI386Instr sty (FCOMP sz op)
+pprI386Instr sty (FCOMP sz op)
= uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppChar ' ', pprOperand sty sz op]
pprI386Instr sty FUCOMPP = uppPStr SLIT("\tfucompp")
pprI386Instr sty FXCH = uppPStr SLIT("\tfxch")
asciify :: String -> Int -> Unpretty
asciify [] _ = uppStr ("\\0\"")
asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
- asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
- asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
- asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
+ asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
+ asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
+ asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
asciify (c:(cs@(d:_))) n | isDigit d =
uppBeside (uppStr (charToC c)) (asciify cs 0)
(ints, floats) = partition (< 8) xs
floats' = map (subtract 8) floats
- possibleMRegs FloatKind (SRegs _ floats) = [ x + 8 | x <- listBS floats]
- possibleMRegs DoubleKind (SRegs _ floats) = [ x + 8 | x <- listBS floats]
+ possibleMRegs FloatRep (SRegs _ floats) = [ x + 8 | x <- listBS floats]
+ possibleMRegs DoubleRep (SRegs _ floats) = [ x + 8 | x <- listBS floats]
possibleMRegs _ (SRegs ints _) = listBS ints
useMReg (SRegs ints floats) n =
SRegs (ints `minusBS` ints')
(floats `minusBS` floats')
where
- SRegs ints' floats' = mkMRegs xs
+ SRegs ints' floats' = mkMRegs xs
freeMReg (SRegs ints floats) n =
if n _LT_ ILIT(8) then SRegs (ints `unionBS` singletonBS IBOX(n)) floats
else SRegs ints (floats `unionBS` singletonBS (IBOX(n _SUB_ ILIT(8))))
freeMRegs (SRegs ints floats) xs =
- SRegs (ints `unionBS` ints')
+ SRegs (ints `unionBS` ints')
(floats `unionBS` floats')
where
- SRegs ints' floats' = mkMRegs xs
+ SRegs ints' floats' = mkMRegs xs
instance MachineCode I386Instr where
- -- Alas, we don't do anything clever with our OrdLists
---OLD:
--- flatten = flattenOrdList
-
regUsage = i386RegUsage
regLiveness = i386RegLiveness
patchRegs = i386PatchRegs
-- We spill just below the stack pointer, leaving two words per spill location.
- spillReg dyn (MemoryReg i pk)
+ spillReg dyn (MemoryReg i pk)
= trace "spillsave"
- (mkUnitList (MOV (kindToSize pk) (OpReg dyn) (OpAddr (spRel (-2 * i)))))
- loadReg (MemoryReg i pk) dyn
+ (mkUnitList (MOV (kindToSize pk) (OpReg dyn) (OpAddr (spRel (-2 * i)))))
+ loadReg (MemoryReg i pk) dyn
= trace "spillload"
- (mkUnitList (MOV (kindToSize pk) (OpAddr (spRel (-2 * i))) (OpReg dyn)))
+ (mkUnitList (MOV (kindToSize pk) (OpAddr (spRel (-2 * i))) (OpReg dyn)))
--spRel gives us a stack relative addressing mode for volatile temporaries
--and for excess call arguments.
-spRel
+spRel
:: Int -- desired stack offset in words, positive or negative
-> Addr
spRel n = Addr (Just esp) Nothing (ImmInt (n * 4))
-kindToSize :: PrimKind -> Size
-kindToSize PtrKind = L
-kindToSize CodePtrKind = L
-kindToSize DataPtrKind = L
-kindToSize RetKind = L
-kindToSize InfoPtrKind = L
-kindToSize CostCentreKind = L
-kindToSize CharKind = L
-kindToSize IntKind = L
-kindToSize WordKind = L
-kindToSize AddrKind = L
-kindToSize FloatKind = F
-kindToSize DoubleKind = D
-kindToSize ArrayKind = L
-kindToSize ByteArrayKind = L
-kindToSize StablePtrKind = L
-kindToSize MallocPtrKind = L
+kindToSize :: PrimRep -> Size
+kindToSize PtrRep = L
+kindToSize CodePtrRep = L
+kindToSize DataPtrRep = L
+kindToSize RetRep = L
+kindToSize CostCentreRep = L
+kindToSize CharRep = L
+kindToSize IntRep = L
+kindToSize WordRep = L
+kindToSize AddrRep = L
+kindToSize FloatRep = F
+kindToSize DoubleRep = D
+kindToSize ArrayRep = L
+kindToSize ByteArrayRep = L
+kindToSize StablePtrRep = L
+kindToSize MallocPtrRep = L
\end{code}
usage1 (OpAddr ea) = usage (addrToRegs ea) []
allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7]
--callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway.
- callClobberedRegs = [eax]
+ callClobberedRegs = [eax]
-- General purpose register collecting functions.
addrToRegs (Addr base index _) = baseToReg base ++ indexToReg index
where baseToReg Nothing = []
- baseToReg (Just r) = [r]
- indexToReg Nothing = []
- indexToReg (Just (r,_)) = [r]
+ baseToReg (Just r) = [r]
+ indexToReg Nothing = []
+ indexToReg (Just (r,_)) = [r]
addrToRegs (ImmAddr _ _) = []
usage src dst = RU (mkUniqSet (filter interesting src))
lookup lbl = case lookupFM env lbl of
Just regs -> regs
Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
- " in future?") emptyUniqSet
+ " in future?") emptyUniqSet
\end{code}
ADD sz src dst -> patch2 (ADD sz) src dst
SUB sz src dst -> patch2 (SUB sz) src dst
IMUL sz src dst -> patch2 (IMUL sz) src dst
- IDIV sz src -> patch1 (IDIV sz) src
+ IDIV sz src -> patch1 (IDIV sz) src
AND sz src dst -> patch2 (AND sz) src dst
OR sz src dst -> patch2 (OR sz) src dst
XOR sz src dst -> patch2 (XOR sz) src dst
FISUBR sz asrc -> FISUBR sz (lookupAddr asrc)
FCOMP sz src -> FCOMP sz (patchOp src)
_ -> instr
-
+
where
patch1 insn op = insn (patchOp op)
patch2 insn src dst = insn (patchOp src) (patchOp dst)
patchOp (OpImm imm) = OpImm imm
patchOp (OpAddr ea) = OpAddr (lookupAddr ea)
- lookupAddr (Addr base index disp)
+ lookupAddr (Addr base index disp)
= Addr (lookupBase base) (lookupIndex index) disp
where lookupBase Nothing = Nothing
lookupBase (Just r) = Just (env r)
lookupIndex Nothing = Nothing
lookupIndex (Just (r,i)) = Just (env r, i)
- lookupAddr (ImmAddr imm off)
+ lookupAddr (ImmAddr imm off)
= ImmAddr imm off
\end{code}
(Okay, just for chrCode of a fetch.)
\begin{code}
-
-#ifdef __GLASGOW_HASKELL__
-
{-# SPECIALIZE
is13Bits :: Int -> Bool
#-}
is13Bits :: Integer -> Bool
#-}
-#endif
-
is13Bits :: Integral a => a -> Bool
is13Bits x = x >= -4096 && x < 4096
where off3 = off1 + off2
offset _ _ = Nothing
-
\end{code}
If you value your sanity, do not venture below this line.
#define st5 13
#define st6 14
#define st7 15
-#define CALLER_SAVES_Hp
+#define CALLER_SAVES_Hp
-- ToDo: rm when we give esp back
#define REG_Hp esp
#define REG_R2 ecx
#ifdef CALLER_SAVES_SuB
callerSaves SuB = True
#endif
-#ifdef CALLER_SAVES_Hp
+#ifdef CALLER_SAVES_Hp
callerSaves Hp = True
#endif
#ifdef CALLER_SAVES_HpLim
#ifdef REG_SuB
stgRegMap SuB = Just (FixedReg ILIT(REG_SuB))
#endif
-#ifdef REG_Hp
+#ifdef REG_Hp
stgRegMap Hp = Just (FixedReg ILIT(REG_Hp))
#endif
#ifdef REG_HpLim
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface I386Desc where
-import AbsCSyn(MagicId)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
-data RegLoc {-# GHC_PRAGMA Save StixTree | Always StixTree #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
-mkI386 :: Bool -> (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char])
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
-
#include "HsVersions.h"
module I386Desc (
- mkI386,
+ mkI386
-- and assorted nonsense referenced by the class methods
-
- PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult
-
) where
import AbsCSyn
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..),
RegLiveness(..), RegUsage(..), FutureLive(..)
)
-import CLabelInfo ( CLabel )
+import CLabel ( CLabel )
import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
import HeapOffs ( hpRelToInt )
import MachDesc
import Maybes ( Maybe(..) )
import OrdList
import Outputable
-import PrimKind ( PrimKind(..) )
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import I386Code
import I386Gen ( i386CodeGen )
import Stix
import StixMacro
import StixPrim
-import SplitUniq
-import Unique
+import UniqSupply
import Util
-
\end{code}
Header sizes depend only on command-line options, not on the target
StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
BaseReg -> sStLitLbl SLIT("MainRegTable")
- --Hp -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo"))
- --HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+4"))
- TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*4)])
- where
- r2 = VanillaReg PtrKind ILIT(2)
+ --Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
+ --HpLim -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo+4"))
+ TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, StInt (1*4)])
+ where
+ r2 = VanillaReg PtrRep ILIT(2)
infoptr = case i386Reg switches r2 of
Always tree -> tree
Save _ -> StReg (StixMagicId r2)
baseLoc = case stgRegMap BaseReg of
Just _ -> StReg (StixMagicId BaseReg)
Nothing -> sStLitLbl SLIT("MainRegTable")
- offset = baseRegOffset x
-
+ offset = baseRegOffset x
+
\end{code}
Sizes in bytes.
\begin{code}
-vsaves switches vols =
+vsaves switches vols =
map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
where
- save x = StAssign (kindFromMagicId x) loc reg
+ save x = StAssign (kindFromMagicId x) loc reg
where reg = StReg (StixMagicId x)
loc = case i386Reg switches x of
Save loc -> loc
Always loc -> panic "vsaves"
-vrests switches vols =
- map restore ((filter callerSaves)
+vrests switches vols =
+ map restore ((filter callerSaves)
([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols))
where
- restore x = StAssign (kindFromMagicId x) reg loc
+ restore x = StAssign (kindFromMagicId x) reg loc
where reg = StReg (StixMagicId x)
loc = case i386Reg switches x of
Save loc -> loc
charLikeSize, intLikeSize :: Target -> Int
-charLikeSize target =
- size PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
+charLikeSize target =
+ size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
-intLikeSize target =
- size PtrKind * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
+intLikeSize target =
+ size PtrRep * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
mhs switches = StInt (toInteger words)
- where
+ where
words = fhs switches + vhs switches (MuTupleRep 0)
dhs switches = StInt (toInteger words)
- where
+ where
words = fhs switches + vhs switches (DataRep 0)
\end{code}
mkI386 :: Bool
-> (GlobalSwitch -> SwitchResult)
-> (Target,
- (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen
+ (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen
Bool, -- underscore
(String -> String)) -- fmtAsmLbl
-mkI386 decentOS switches =
+mkI386 decentOS switches =
let fhs' = fhs switches
vhs' = vhs switches
i386Reg' = i386Reg switches
vsaves' = vsaves switches
vrests' = vrests switches
- hprel = hpRelToInt target
- as = amodeCode target
- as' = amodeCode' target
+ hprel = hpRelToInt target
+ as = amodeCode target
+ as' = amodeCode' target
csz = charLikeSize target
isz = intLikeSize target
mhs' = mhs switches
dhs' = dhs switches
ps = genPrimCode target
mc = genMacroCode target
- hc = doHeapCheck --UNUSED NOW: target
+ hc = doHeapCheck
target = mkTarget {-switches-} fhs' vhs' i386Reg' {-id-} size
hprel as as'
(vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
in
(target, i386CodeGen, decentOS, id)
\end{code}
-
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface I386Gen where
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
-i386CodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-}
-
IMPORT_Trace
import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos,
- Reg(..), RegLiveness(..), RegUsage(..),
+ Reg(..), RegLiveness(..), RegUsage(..),
FutureLive(..), MachineRegisters(..), MachineCode(..)
)
-import CLabelInfo ( CLabel, isAsmTemp )
+import CLabel ( CLabel, isAsmTemp )
import I386Code {- everything -}
import MachDesc
import Maybes ( maybeToBool, Maybe(..) )
import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
import Outputable
-import PrimKind ( PrimKind(..), isFloatingKind )
import I386Desc
import Stix
-import SplitUniq
-import Unique
+import UniqSupply
import Pretty
import Unpretty
import Util
type CodeBlock a = (OrdList a -> OrdList a)
-
\end{code}
%************************************************************************
\begin{code}
-i386CodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
-i386CodeGen sty trees =
- mapSUs genI386Code trees `thenSUs` \ dynamicCodes ->
+i386CodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
+i386CodeGen sty trees =
+ mapUs genI386Code trees `thenUs` \ dynamicCodes ->
let
staticCodes = scheduleI386Code dynamicCodes
pretty = printLabeledCodes sty staticCodes
in
- returnSUs pretty
+ returnUs pretty
\end{code}
\begin{code}
-data Register
- = Fixed Reg PrimKind (CodeBlock I386Instr)
- | Any PrimKind (Reg -> (CodeBlock I386Instr))
+data Register
+ = Fixed Reg PrimRep (CodeBlock I386Instr)
+ | Any PrimRep (Reg -> (CodeBlock I386Instr))
registerCode :: Register -> Reg -> CodeBlock I386Instr
registerCode (Fixed _ _ code) reg = code
registerName (Fixed reg _ _) _ = reg
registerName (Any _ _) reg = reg
-registerKind :: Register -> PrimKind
+registerKind :: Register -> PrimRep
registerKind (Fixed _ pk _) = pk
registerKind (Any pk _) = pk
asmParThen :: [I386Code] -> (CodeBlock I386Instr)
asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-returnInstr :: I386Instr -> SUniqSM (CodeBlock I386Instr)
-returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
+returnInstr :: I386Instr -> UniqSM (CodeBlock I386Instr)
+returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-returnInstrs :: [I386Instr] -> SUniqSM (CodeBlock I386Instr)
-returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
+returnInstrs :: [I386Instr] -> UniqSM (CodeBlock I386Instr)
+returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> SUniqSM (CodeBlock I386Instr)
-returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> UniqSM (CodeBlock I386Instr)
+returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
mkSeqInstr :: I386Instr -> (CodeBlock I386Instr)
mkSeqInstr instr code = mkSeqList (asmInstr instr) code
\begin{code}
-genI386Code :: [StixTree] -> SUniqSM (I386Code)
+genI386Code :: [StixTree] -> UniqSM (I386Code)
genI386Code trees =
- mapSUs getCode trees `thenSUs` \ blocks ->
- returnSUs (foldr (.) id blocks asmVoid)
+ mapUs getCode trees `thenUs` \ blocks ->
+ returnUs (foldr (.) id blocks asmVoid)
\end{code}
\begin{code}
-getCode
+getCode
:: StixTree -- a stix statement
- -> SUniqSM (CodeBlock I386Instr)
+ -> UniqSM (CodeBlock I386Instr)
getCode (StSegment seg) = returnInstr (SEGMENT seg)
getCode (StAssign pk dst src)
- | isFloatingKind pk = assignFltCode pk dst src
+ | isFloatingRep pk = assignFltCode pk dst src
| otherwise = assignIntCode pk dst src
getCode (StLabel lab) = returnInstr (LABEL lab)
getCode (StFunBegin lab) = returnInstr (LABEL lab)
-getCode (StFunEnd lab) = returnSUs id
+getCode (StFunEnd lab) = returnUs id
getCode (StJump arg) = genJump arg
-getCode (StFallThrough lbl) = returnSUs id
+getCode (StFallThrough lbl) = returnUs id
getCode (StCondJump lbl arg) = genCondJump lbl arg
-getCode (StData kind args) =
- mapAndUnzipSUs getData args `thenSUs` \ (codes, imms) ->
- returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
- (foldr1 (.) codes xs))
+getCode (StData kind args) =
+ mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
+ returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
+ (foldr1 (.) codes xs))
where
- getData :: StixTree -> SUniqSM (CodeBlock I386Instr, Imm)
- getData (StInt i) = returnSUs (id, ImmInteger i)
-#if __GLASGOW_HASKELL__ >= 23
--- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : _showRational 30 d))
- -- yurgh (WDP 94/12)
- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
-#else
- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : show d))
-#endif
- getData (StLitLbl s) = returnSUs (id, ImmLit (uppBeside (uppChar '_') s))
- getData (StLitLit s) = returnSUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
- getData (StString s) =
- getUniqLabelNCG `thenSUs` \ lbl ->
- returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
- getData (StCLbl l) = returnSUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
+ getData :: StixTree -> UniqSM (CodeBlock I386Instr, Imm)
+ getData (StInt i) = returnUs (id, ImmInteger i)
+ getData (StDouble d) = returnUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
+ getData (StLitLbl s) = returnUs (id, ImmLit (uppBeside (uppChar '_') s))
+ getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
+ getData (StString s) =
+ getUniqLabelNCG `thenUs` \ lbl ->
+ returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
+ getData (StCLbl l) = returnUs (id, ImmCLbl l)
+
+getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
getCode (StComment s) = returnInstr (COMMENT s)
\begin{code}
-getReg :: StixTree -> SUniqSM Register
+getReg :: StixTree -> UniqSM Register
getReg (StReg (StixMagicId stgreg)) =
case stgRegMap stgreg of
- Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
+ Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
-- cannot be Nothing
-getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
+getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
getReg (StDouble 0.0)
= let
code dst = mkSeqInstrs [FLDZ]
in
- returnSUs (Any DoubleKind code)
+ returnUs (Any DoubleRep code)
getReg (StDouble 1.0)
= let
code dst = mkSeqInstrs [FLD1]
in
- returnSUs (Any DoubleKind code)
+ returnUs (Any DoubleRep code)
getReg (StDouble d) =
- getUniqLabelNCG `thenSUs` \ lbl ->
- --getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getUniqLabelNCG `thenUs` \ lbl ->
+ --getNewRegNCG PtrRep `thenUs` \ tmp ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
-#if __GLASGOW_HASKELL__ >= 23
--- DATA D [strImmLit ('0' : 'd' :_showRational 30 d)],
DATA D [strImmLit ('0' : 'd' :ppShow 80 (ppRational d))],
-#else
- DATA D [strImmLit ('0' : 'd' :show d)],
-#endif
SEGMENT TextSegment,
- FLD D (OpImm (ImmCLbl lbl))
- ]
+ FLD D (OpImm (ImmCLbl lbl))
+ ]
in
- returnSUs (Any DoubleKind code)
+ returnUs (Any DoubleRep code)
getReg (StString s) =
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
SEGMENT TextSegment,
MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
SEGMENT TextSegment,
MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
where
xs = _UNPK_ (_TAIL_ s)
getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
-getReg (StCall fn kind args) =
- genCCall fn kind args `thenSUs` \ call ->
- returnSUs (Fixed reg kind call)
+getReg (StCall fn kind args) =
+ genCCall fn kind args `thenUs` \ call ->
+ returnUs (Fixed reg kind call)
where
- reg = if isFloatingKind kind then st0 else eax
+ reg = if isFloatingRep kind then st0 else eax
-getReg (StPrim primop args) =
+getReg (StPrim primop args) =
case primop of
CharGtOp -> condIntReg GT args
CharLtOp -> condIntReg LT args
CharLeOp -> condIntReg LE args
- IntAddOp -> -- this should be optimised by the generic Opts,
- -- I don't know why it is not (sometimes)!
- case args of
- [x, StInt 0] -> getReg x
- _ -> addCode L args
+ IntAddOp -> -- this should be optimised by the generic Opts,
+ -- I don't know why it is not (sometimes)!
+ case args of
+ [x, StInt 0] -> getReg x
+ _ -> addCode L args
IntSubOp -> subCode L args
IntMulOp -> trivialCode (IMUL L) args True
IntRemOp -> divCode L args False -- remainder
IntNegOp -> trivialUCode (NEGI L) args
IntAbsOp -> absIntCode args
-
+
AndOp -> trivialCode (AND L) args True
OrOp -> trivialCode (OR L) args True
NotOp -> trivialUCode (NOT L) args
ISllOp -> panic "I386Gen:isll"
ISraOp -> panic "I386Gen:isra"
ISrlOp -> panic "I386Gen:isrl"
-
+
IntGtOp -> condIntReg GT args
IntGeOp -> condIntReg GE args
IntEqOp -> condIntReg EQ args
IntNeOp -> condIntReg NE args
IntLtOp -> condIntReg LT args
IntLeOp -> condIntReg LE args
-
+
WordGtOp -> condIntReg GU args
WordGeOp -> condIntReg GEU args
WordEqOp -> condIntReg EQ args
AddrLtOp -> condIntReg LU args
AddrLeOp -> condIntReg LEU args
- FloatAddOp -> trivialFCode FloatKind FADD FADD FADDP FADDP args
- FloatSubOp -> trivialFCode FloatKind FSUB FSUBR FSUBP FSUBRP args
- FloatMulOp -> trivialFCode FloatKind FMUL FMUL FMULP FMULP args
- FloatDivOp -> trivialFCode FloatKind FDIV FDIVR FDIVP FDIVRP args
- FloatNegOp -> trivialUFCode FloatKind FCHS args
+ FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP args
+ FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP args
+ FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP args
+ FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP args
+ FloatNegOp -> trivialUFCode FloatRep FCHS args
FloatGtOp -> condFltReg GT args
FloatGeOp -> condFltReg GE args
FloatLtOp -> condFltReg LT args
FloatLeOp -> condFltReg LE args
- FloatExpOp -> promoteAndCall SLIT("exp") DoubleKind
- FloatLogOp -> promoteAndCall SLIT("log") DoubleKind
- FloatSqrtOp -> trivialUFCode FloatKind FSQRT args
-
- FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind
- --trivialUFCode FloatKind FSIN args
- FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind
- --trivialUFCode FloatKind FCOS args
- FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind
-
- FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind
- FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind
- FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind
-
- FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind
- FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind
- FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind
-
- FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind
-
- DoubleAddOp -> trivialFCode DoubleKind FADD FADD FADDP FADDP args
- DoubleSubOp -> trivialFCode DoubleKind FSUB FSUBR FSUBP FSUBRP args
- DoubleMulOp -> trivialFCode DoubleKind FMUL FMUL FMULP FMULP args
- DoubleDivOp -> trivialFCode DoubleKind FDIV FDIVR FDIVP FDIVRP args
- DoubleNegOp -> trivialUFCode DoubleKind FCHS args
-
+ FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
+ FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
+ FloatSqrtOp -> trivialUFCode FloatRep FSQRT args
+
+ FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
+ --trivialUFCode FloatRep FSIN args
+ FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
+ --trivialUFCode FloatRep FCOS args
+ FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
+
+ FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
+ FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
+ FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
+
+ FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
+ FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
+ FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
+
+ FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
+
+ DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP args
+ DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP args
+ DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP args
+ DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP args
+ DoubleNegOp -> trivialUFCode DoubleRep FCHS args
+
DoubleGtOp -> condFltReg GT args
DoubleGeOp -> condFltReg GE args
DoubleEqOp -> condFltReg EQ args
DoubleLtOp -> condFltReg LT args
DoubleLeOp -> condFltReg LE args
- DoubleExpOp -> call SLIT("exp") DoubleKind
- DoubleLogOp -> call SLIT("log") DoubleKind
- DoubleSqrtOp -> trivialUFCode DoubleKind FSQRT args
-
- DoubleSinOp -> call SLIT("sin") DoubleKind
- --trivialUFCode DoubleKind FSIN args
- DoubleCosOp -> call SLIT("cos") DoubleKind
- --trivialUFCode DoubleKind FCOS args
- DoubleTanOp -> call SLIT("tan") DoubleKind
-
- DoubleAsinOp -> call SLIT("asin") DoubleKind
- DoubleAcosOp -> call SLIT("acos") DoubleKind
- DoubleAtanOp -> call SLIT("atan") DoubleKind
-
- DoubleSinhOp -> call SLIT("sinh") DoubleKind
- DoubleCoshOp -> call SLIT("cosh") DoubleKind
- DoubleTanhOp -> call SLIT("tanh") DoubleKind
-
- DoublePowerOp -> call SLIT("pow") DoubleKind
-
- OrdOp -> coerceIntCode IntKind args
+ DoubleExpOp -> call SLIT("exp") DoubleRep
+ DoubleLogOp -> call SLIT("log") DoubleRep
+ DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT args
+
+ DoubleSinOp -> call SLIT("sin") DoubleRep
+ --trivialUFCode DoubleRep FSIN args
+ DoubleCosOp -> call SLIT("cos") DoubleRep
+ --trivialUFCode DoubleRep FCOS args
+ DoubleTanOp -> call SLIT("tan") DoubleRep
+
+ DoubleAsinOp -> call SLIT("asin") DoubleRep
+ DoubleAcosOp -> call SLIT("acos") DoubleRep
+ DoubleAtanOp -> call SLIT("atan") DoubleRep
+
+ DoubleSinhOp -> call SLIT("sinh") DoubleRep
+ DoubleCoshOp -> call SLIT("cosh") DoubleRep
+ DoubleTanhOp -> call SLIT("tanh") DoubleRep
+
+ DoublePowerOp -> call SLIT("pow") DoubleRep
+
+ OrdOp -> coerceIntCode IntRep args
ChrOp -> chrCode args
Float2IntOp -> coerceFP2Int args
- Int2FloatOp -> coerceInt2FP FloatKind args
+ Int2FloatOp -> coerceInt2FP FloatRep args
Double2IntOp -> coerceFP2Int args
- Int2DoubleOp -> coerceInt2FP DoubleKind args
+ Int2DoubleOp -> coerceInt2FP DoubleRep args
Double2FloatOp -> coerceFltCode args
Float2DoubleOp -> coerceFltCode args
call fn pk = getReg (StCall fn pk args)
promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
where
- promote x = StPrim Float2DoubleOp [x]
+ promote x = StPrim Float2DoubleOp [x]
getReg (StInd pk mem) =
- getAmode mem `thenSUs` \ amode ->
- let
+ getAmode mem `thenUs` \ amode ->
+ let
code = amodeCode amode
src = amodeAddr amode
size = kindToSize pk
- code__2 dst = code .
- if pk == DoubleKind || pk == FloatKind
- then mkSeqInstr (FLD {-D-} size (OpAddr src))
- else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
+ code__2 dst = code .
+ if pk == DoubleRep || pk == FloatRep
+ then mkSeqInstr (FLD {-D-} size (OpAddr src))
+ else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
getReg (StInt i)
src = ImmInt (fromInteger i)
code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
in
- returnSUs (Any IntKind code)
+ returnUs (Any IntRep code)
getReg leaf
| maybeToBool imm =
let
- code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
+ code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
\begin{code}
-getAmode :: StixTree -> SUniqSM Amode
+getAmode :: StixTree -> UniqSM Amode
getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
getAmode (StPrim IntSubOp [x, StInt i])
=
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg x `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg x `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnSUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (Addr (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, StInt i])
- | maybeToBool imm
+ | maybeToBool imm
= let
- code = mkSeqInstrs []
+ code = mkSeqInstrs []
in
- returnSUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
+ returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
where
imm = maybeImm x
imm__2 = case imm of Just x -> x
getAmode (StPrim IntAddOp [x, StInt i])
=
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg x `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg x `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnSUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (Addr (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, y]) =
- getNewRegNCG PtrKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
+ getNewRegNCG PtrRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
let
code1 = registerCode register1 tmp1 asmVoid
reg1 = registerName register1 tmp1
reg2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2]
in
- returnSUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+ returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
getAmode leaf
| maybeToBool imm =
let code = mkSeqInstrs []
in
- returnSUs (Amode (ImmAddr imm__2 0) code)
+ returnUs (Amode (ImmAddr imm__2 0) code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
getAmode other =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg other `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg other `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = Nothing
in
- returnSUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
+ returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
\end{code}
\begin{code}
getOp
- :: StixTree
- -> SUniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
+ :: StixTree
+ -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
getOp (StInt i)
- = returnSUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
+ = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
getOp (StInd pk mem)
- = getAmode mem `thenSUs` \ amode ->
+ = getAmode mem `thenUs` \ amode ->
let
code = amodeCode amode --asmVoid
addr = amodeAddr amode
sz = kindToSize pk
- in returnSUs (code, OpAddr addr, sz)
+ in returnUs (code, OpAddr addr, sz)
getOp op
- = getReg op `thenSUs` \ register ->
+ = getReg op `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
- let
+ `thenUs` \ tmp ->
+ let
code = registerCode register tmp
reg = registerName register tmp
pk = registerKind register
sz = kindToSize pk
in
- returnSUs (code, OpReg reg, sz)
+ returnUs (code, OpReg reg, sz)
getOpRI
- :: StixTree
- -> SUniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
+ :: StixTree
+ -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
getOpRI op
| maybeToBool imm
- = returnSUs (asmParThen [], OpImm imm_op, L)
+ = returnUs (asmParThen [], OpImm imm_op, L)
where
imm = maybeImm op
imm_op = case imm of Just x -> x
getOpRI op
- = getReg op `thenSUs` \ register ->
+ = getReg op `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
- let
+ `thenUs` \ tmp ->
+ let
code = registerCode register tmp
reg = registerName register tmp
pk = registerKind register
sz = kindToSize pk
in
- returnSUs (code, OpReg reg, sz)
+ returnUs (code, OpReg reg, sz)
\end{code}
\begin{code}
-getCondition :: StixTree -> SUniqSM Condition
+getCondition :: StixTree -> UniqSM Condition
-getCondition (StPrim primop args) =
+getCondition (StPrim primop args) =
case primop of
CharGtOp -> condIntCode GT args
IntNeOp -> condIntCode NE args
IntLtOp -> condIntCode LT args
IntLeOp -> condIntCode LE args
-
+
WordGtOp -> condIntCode GU args
WordGeOp -> condIntCode GEU args
WordEqOp -> condIntCode EQ args
\begin{code}
-condIntCode, condFltCode :: Cond -> [StixTree] -> SUniqSM Condition
-condIntCode cond [StInd _ x, y]
+condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
+condIntCode cond [StInd _ x, y]
| maybeToBool imm
- = getAmode x `thenSUs` \ amode ->
+ = getAmode x `thenUs` \ amode ->
let
code1 = amodeCode amode asmVoid
y__2 = amodeAddr amode
- code__2 = asmParThen [code1] .
+ code__2 = asmParThen [code1] .
mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
where
imm = maybeImm y
imm__2 = case imm of Just x -> x
-condIntCode cond [x, StInt 0]
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+condIntCode cond [x, StInt 0]
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code__2 = asmParThen [code1] .
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code__2 = asmParThen [code1] .
mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
-condIntCode cond [x, y]
+condIntCode cond [x, y]
| maybeToBool imm
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code__2 = asmParThen [code1] .
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code__2 = asmParThen [code1] .
mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
where
imm = maybeImm y
imm__2 = case imm of Just x -> x
-condIntCode cond [StInd _ x, y]
- = getAmode x `thenSUs` \ amode ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+condIntCode cond [StInd _ x, y]
+ = getAmode x `thenUs` \ amode ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = amodeCode amode asmVoid
src1 = amodeAddr amode
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
-condIntCode cond [y, StInd _ x]
- = getAmode x `thenSUs` \ amode ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+condIntCode cond [y, StInd _ x]
+ = getAmode x `thenUs` \ amode ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = amodeCode amode asmVoid
src1 = amodeAddr amode
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
condIntCode cond [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
condFltCode cond [x, StDouble 0.0] =
- getReg x `thenSUs` \ register1 ->
+ getReg x `thenUs` \ register1 ->
getNewRegNCG (registerKind register1)
- `thenSUs` \ tmp1 ->
+ `thenUs` \ tmp1 ->
let
pk1 = registerKind register1
code1 = registerCode register1 tmp1
code__2 = asmParThen [code1 asmVoid] .
mkSeqInstrs [FTST, FSTP D (OpReg st0), -- or FLDZ, FUCOMPP ?
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
+ FNSTSW,
+ --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+ --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+ SAHF
+ ]
in
- returnSUs (Condition True (fixFPCond cond) code__2)
+ returnUs (Condition True (fixFPCond cond) code__2)
condFltCode cond [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
getNewRegNCG (registerKind register1)
- `thenSUs` \ tmp1 ->
+ `thenUs` \ tmp1 ->
getNewRegNCG (registerKind register2)
- `thenSUs` \ tmp2 ->
+ `thenUs` \ tmp2 ->
let
pk1 = registerKind register1
code1 = registerCode register1 tmp1
code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
mkSeqInstrs [FUCOMPP,
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
+ FNSTSW,
+ --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+ --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+ SAHF
+ ]
in
- returnSUs (Condition True (fixFPCond cond) code__2)
+ returnUs (Condition True (fixFPCond cond) code__2)
\end{code}
\begin{code}
-condIntReg :: Cond -> [StixTree] -> SUniqSM Register
+condIntReg :: Cond -> [StixTree] -> UniqSM Register
condIntReg cond args =
- condIntCode cond args `thenSUs` \ condition ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- --getReg dst `thenSUs` \ register ->
- let
+ condIntCode cond args `thenUs` \ condition ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ --getReg dst `thenUs` \ register ->
+ let
--code2 = registerCode register tmp asmVoid
--dst__2 = registerName register tmp
- code = condCode condition
- cond = condName condition
+ code = condCode condition
+ cond = condName condition
-- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code . mkSeqInstrs [
SETCC cond (OpReg tmp),
AND L (OpImm (ImmInt 1)) (OpReg tmp),
- MOV L (OpReg tmp) (OpReg dst)]
+ MOV L (OpReg tmp) (OpReg dst)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-condFltReg :: Cond -> [StixTree] -> SUniqSM Register
+condFltReg :: Cond -> [StixTree] -> UniqSM Register
condFltReg cond args =
- getUniqLabelNCG `thenSUs` \ lbl1 ->
- getUniqLabelNCG `thenSUs` \ lbl2 ->
- condFltCode cond args `thenSUs` \ condition ->
+ getUniqLabelNCG `thenUs` \ lbl1 ->
+ getUniqLabelNCG `thenUs` \ lbl2 ->
+ condFltCode cond args `thenUs` \ condition ->
let
code = condCode condition
cond = condName condition
code__2 dst = code . mkSeqInstrs [
- JXX cond lbl1,
+ JXX cond lbl1,
MOV L (OpImm (ImmInt 0)) (OpReg dst),
JXX ALWAYS lbl2,
LABEL lbl1,
MOV L (OpImm (ImmInt 1)) (OpReg dst),
LABEL lbl2]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
some of the register transfers will go away, because we can use the destination
register to complete the code generation for the right hand side. This only
fails when the right hand side is forced into a fixed register (e.g. the result
-of a call).
+of a call).
\begin{code}
-assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr)
-assignIntCode pk (StInd _ dst) src
- = getAmode dst `thenSUs` \ amode ->
- getOpRI src `thenSUs` \ (codesrc, opsrc, sz) ->
- let
+assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
+assignIntCode pk (StInd _ dst) src
+ = getAmode dst `thenUs` \ amode ->
+ getOpRI src `thenUs` \ (codesrc, opsrc, sz) ->
+ let
code1 = amodeCode amode asmVoid
dst__2 = amodeAddr amode
- code__2 = asmParThen [code1, codesrc asmVoid] .
- mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
+ code__2 = asmParThen [code1, codesrc asmVoid] .
+ mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
in
- returnSUs code__2
+ returnUs code__2
assignIntCode pk dst (StInd _ src) =
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode src `thenSUs` \ amode ->
- getReg dst `thenSUs` \ register ->
- let
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode src `thenUs` \ amode ->
+ getReg dst `thenUs` \ register ->
+ let
code1 = amodeCode amode asmVoid
src__2 = amodeAddr amode
code2 = registerCode register tmp asmVoid
dst__2 = registerName register tmp
sz = kindToSize pk
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
in
- returnSUs code__2
+ returnUs code__2
assignIntCode pk dst src =
- getReg dst `thenSUs` \ register1 ->
- getReg src `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- let
+ getReg dst `thenUs` \ register1 ->
+ getReg src `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
dst__2 = registerName register1 tmp
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2 && dst__2 /= src__2
then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
- else
- code
+ else
+ code
in
- returnSUs code__2
-
-assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr)
-assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
- = getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode src `thenSUs` \ amodesrc ->
- getAmode dst `thenSUs` \ amodedst ->
- --getReg src `thenSUs` \ register ->
- let
+ returnUs code__2
+
+assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
+assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
+ = getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode src `thenUs` \ amodesrc ->
+ getAmode dst `thenUs` \ amodedst ->
+ --getReg src `thenUs` \ register ->
+ let
codesrc1 = amodeCode amodesrc asmVoid
addrsrc1 = amodeAddr amodesrc
codedst1 = amodeCode amodedst asmVoid
addrsrc2 = case (offset addrsrc1 4) of Just x -> x
addrdst2 = case (offset addrdst1 4) of Just x -> x
- code__2 = asmParThen [codesrc1, codedst1] .
+ code__2 = asmParThen [codesrc1, codedst1] .
mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
- MOV L (OpReg tmp) (OpAddr addrdst1)]
- ++
- if pk == DoubleKind
- then [MOV L (OpAddr addrsrc2) (OpReg tmp),
- MOV L (OpReg tmp) (OpAddr addrdst2)]
- else [])
+ MOV L (OpReg tmp) (OpAddr addrdst1)]
+ ++
+ if pk == DoubleRep
+ then [MOV L (OpAddr addrsrc2) (OpReg tmp),
+ MOV L (OpReg tmp) (OpAddr addrdst2)]
+ else [])
in
- returnSUs code__2
+ returnUs code__2
assignFltCode pk (StInd _ dst) src =
- --getNewRegNCG pk `thenSUs` \ tmp ->
- getAmode dst `thenSUs` \ amode ->
- getReg src `thenSUs` \ register ->
- let
+ --getNewRegNCG pk `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getReg src `thenUs` \ register ->
+ let
sz = kindToSize pk
dst__2 = amodeAddr amode
pk__2 = registerKind register
sz__2 = kindToSize pk__2
- code__2 = asmParThen [code1, code2] .
+ code__2 = asmParThen [code1, code2] .
mkSeqInstr (FSTP sz (OpAddr dst__2))
in
- returnSUs code__2
+ returnUs code__2
assignFltCode pk dst src =
- getReg dst `thenSUs` \ register1 ->
- getReg src `thenSUs` \ register2 ->
+ getReg dst `thenUs` \ register1 ->
+ getReg src `thenUs` \ register2 ->
--getNewRegNCG (registerKind register2)
- -- `thenSUs` \ tmp ->
- let
+ -- `thenUs` \ tmp ->
+ let
sz = kindToSize pk
dst__2 = registerName register1 st0 --tmp
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
- code__2 = code
+ code__2 = code
in
- returnSUs code__2
+ returnUs code__2
-\end{code}
+\end{code}
Generating an unconditional branch. We accept two types of targets:
an immediate CLabel or a tree that gets evaluated into a register.
\begin{code}
-genJump
+genJump
:: StixTree -- the branch target
- -> SUniqSM (CodeBlock I386Instr)
+ -> UniqSM (CodeBlock I386Instr)
{-
-genJump (StCLbl lbl)
+genJump (StCLbl lbl)
| isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
| otherwise = returnInstrs [JMP (OpImm target)]
where
-}
genJump (StInd pk mem) =
- getAmode mem `thenSUs` \ amode ->
+ getAmode mem `thenUs` \ amode ->
let
code = amodeCode amode
target = amodeAddr amode
in
returnSeq code [JMP (OpAddr target)]
-genJump tree
+genJump tree
| maybeToBool imm
= returnInstr (JMP (OpImm target))
where
genJump tree =
- getReg tree `thenSUs` \ register ->
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getReg tree `thenUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
let
code = registerCode register tmp
target = registerName register tmp
\begin{code}
-genCondJump
+genCondJump
:: CLabel -- the branch target
-> StixTree -- the condition on which to branch
- -> SUniqSM (CodeBlock I386Instr)
+ -> UniqSM (CodeBlock I386Instr)
-genCondJump lbl bool =
- getCondition bool `thenSUs` \ condition ->
+genCondJump lbl bool =
+ getCondition bool `thenUs` \ condition ->
let
code = condCode condition
cond = condName condition
- target = ImmCLbl lbl
+ target = ImmCLbl lbl
in
- returnSeq code [JXX cond lbl]
+ returnSeq code [JXX cond lbl]
\end{code}
genCCall
:: FAST_STRING -- function to call
- -> PrimKind -- type of the result
+ -> PrimRep -- type of the result
-> [StixTree] -- arguments (of mixed type)
- -> SUniqSM (CodeBlock I386Instr)
+ -> UniqSM (CodeBlock I386Instr)
-genCCall fn kind [StInt i]
+genCCall fn kind [StInt i]
| fn == SLIT ("PerformGC_wrapper")
- = getUniqLabelNCG `thenSUs` \ lbl ->
+ = getUniqLabelNCG `thenUs` \ lbl ->
let
- call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- MOV L (OpImm (ImmCLbl lbl))
- -- this is hardwired
- (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
- LABEL lbl]
+ call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
+ MOV L (OpImm (ImmCLbl lbl))
+ -- this is hardwired
+ (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
+ JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
+ LABEL lbl]
in
returnInstrs call
genCCall fn kind args =
- mapSUs getCallArg args `thenSUs` \ argCode ->
+ mapUs getCallArg args `thenUs` \ argCode ->
let
- nargs = length args
- code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
- ]
- ]
- code2 = asmParThen (map ($ asmVoid) (reverse argCode))
- call = [CALL (ImmLit fn__2) -- ,
- -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
- -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
- ]
+ nargs = length args
+ code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
+ MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
+ ]
+ ]
+ code2 = asmParThen (map ($ asmVoid) (reverse argCode))
+ call = [CALL (ImmLit fn__2) -- ,
+ -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
+ -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
+ ]
in
returnSeq (code1 . code2) call
where
'.' -> uppPStr fn
_ -> uppBeside (uppChar '_') (uppPStr fn)
- getCallArg
- :: StixTree -- Current argument
- -> SUniqSM (CodeBlock I386Instr) -- code
- getCallArg arg =
- getOp arg `thenSUs` \ (code, op, sz) ->
- returnSUs (code . mkSeqInstr (PUSH sz op))
+ getCallArg
+ :: StixTree -- Current argument
+ -> UniqSM (CodeBlock I386Instr) -- code
+ getCallArg arg =
+ getOp arg `thenUs` \ (code, op, sz) ->
+ returnUs (code . mkSeqInstr (PUSH sz op))
\end{code}
Trivial (dyadic) instructions. Only look for constants on the right hand
\begin{code}
-trivialCode
- :: (Operand -> Operand -> I386Instr)
+trivialCode
+ :: (Operand -> Operand -> I386Instr)
-> [StixTree]
-> Bool -- is the instr commutative?
- -> SUniqSM Register
+ -> UniqSM Register
trivialCode instr [x, y] _
| maybeToBool imm
- = getReg x `thenSUs` \ register1 ->
- --getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ = getReg x `thenUs` \ register1 ->
+ --getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
+ code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
- in code1 .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
+ in code1 .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpImm imm__2) (OpReg dst)]
+ else
+ mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
where
imm = maybeImm y
imm__2 = case imm of Just x -> x
trivialCode instr [x, y] _
| maybeToBool imm
- = getReg y `thenSUs` \ register1 ->
- --getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ = getReg y `thenUs` \ register1 ->
+ --getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in code1 .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
+ src1 = registerName register1 dst
+ in code1 .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpImm imm__2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
where
imm = maybeImm x
imm__2 = case imm of Just x -> x
trivialCode instr [x, StInd pk mem] _
- = getReg x `thenSUs` \ register ->
- --getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode mem `thenSUs` \ amode ->
+ = getReg x `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode mem `thenUs` \ amode ->
let
fixedname = registerName register eax
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
code__2 dst = let code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+ src1 = registerName register dst
+ in asmParThen [code1, code2] .
+ if isFixed register && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpAddr src2) (OpReg src1))
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
trivialCode instr [StInd pk mem, y] _
- = getReg y `thenSUs` \ register ->
- --getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode mem `thenSUs` \ amode ->
+ = getReg y `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode mem `thenUs` \ amode ->
let
fixedname = registerName register eax
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
- code__2 dst = let
+ code__2 dst = let
code1 = registerCode register dst asmVoid
src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+ in asmParThen [code1, code2] .
+ if isFixed register && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpAddr src2) (OpReg src1))
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
-trivialCode instr [x, y] is_comm_op
- = getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- --getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+trivialCode instr [x, y] is_comm_op
+ = getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ --getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
fixedname = registerName register1 eax
code2 = registerCode register2 tmp2 asmVoid
code__2 dst = let
code1 = registerCode register1 dst asmVoid
src1 = registerName register1 dst
- in asmParThen [code1, code2] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpReg src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpReg src2) (OpReg src1))
+ in asmParThen [code1, code2] .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpReg src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpReg src2) (OpReg src1))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-addCode
+addCode
:: Size
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
addCode sz [x, StInt y]
=
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ code__2 dst = code .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
addCode sz [x, StInd _ mem]
- = getReg x `thenSUs` \ register1 ->
+ = getReg x `thenUs` \ register1 ->
--getNewRegNCG (registerKind register1)
- -- `thenSUs` \ tmp1 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ -- `thenUs` \ tmp1 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code2 = amodeCode amode
src2 = amodeAddr amode
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in asmParThen [code2 asmVoid,code1 asmVoid] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- ADD sz (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ ADD sz (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
addCode sz [StInd _ mem, y]
- = getReg y `thenSUs` \ register2 ->
+ = getReg y `thenUs` \ register2 ->
--getNewRegNCG (registerKind register2)
- -- `thenSUs` \ tmp2 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ -- `thenUs` \ tmp2 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code1 = amodeCode amode
src1 = amodeAddr amode
fixedname = registerName register2 eax
code__2 dst = let code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
- if isFixed register2 && src2 /= dst
- then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
- ADD sz (OpAddr src1) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid,code2 asmVoid] .
+ if isFixed register2 && src2 /= dst
+ then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
+ ADD sz (OpAddr src1) (OpReg dst)]
+ else
+ mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
addCode sz [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
code__2 dst = asmParThen [code1, code2] .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-subCode
+subCode
:: Size
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
subCode sz [x, StInt y]
- = getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ = getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (-(fromInteger y))
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ code__2 dst = code .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
subCode sz args = trivialCode (SUB sz) args False
-divCode
+divCode
:: Size
-> [StixTree]
-> Bool -- True => division, False => remainder operation
- -> SUniqSM Register
+ -> UniqSM Register
--- x must go into eax, edx must be a sign-extension of eax,
+-- x must go into eax, edx must be a sign-extension of eax,
-- and y should go in some other register (or memory),
-- so that we get edx:eax / reg -> eax (remainder in edx)
-- Currently we chose to put y in memory (if it is not there already)
divCode sz [x, StInd pk mem] is_division
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
code__2 = asmParThen [code1, code2] .
- mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr src2)]
+ mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr src2)]
in
- returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+ returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
divCode sz [x, StInt i] is_division
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
src2 = ImmInt (fromInteger i)
code__2 = asmParThen [code1] .
- mkSeqInstrs [-- we put src2 in (ebx)
- MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ mkSeqInstrs [-- we put src2 in (ebx)
+ MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
in
- returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+ returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
divCode sz [x, y] is_division
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2] .
- if src2 == ecx || src2 == esi
- then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpReg src2)]
- else mkSeqInstrs [ -- we put src2 in (ebx)
- MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ if src2 == ecx || src2 == esi
+ then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpReg src2)]
+ else mkSeqInstrs [ -- we put src2 in (ebx)
+ MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
in
- returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+ returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
-trivialFCode
- :: PrimKind
- -> (Size -> Operand -> I386Instr)
+trivialFCode
+ :: PrimRep
+ -> (Size -> Operand -> I386Instr)
-> (Size -> Operand -> I386Instr) -- reversed instr
-> I386Instr -- pop
-> I386Instr -- reversed instr, pop
- -> [StixTree]
- -> SUniqSM Register
+ -> [StixTree]
+ -> UniqSM Register
trivialFCode pk _ instrr _ _ [StInd pk' mem, y]
- = getReg y `thenSUs` \ register2 ->
+ = getReg y `thenUs` \ register2 ->
--getNewRegNCG (registerKind register2)
- -- `thenSUs` \ tmp2 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ -- `thenUs` \ tmp2 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code1 = amodeCode amode
src1 = amodeAddr amode
- code__2 dst = let
+ code__2 dst = let
code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid,code2 asmVoid] .
mkSeqInstrs [instrr (kindToSize pk) (OpAddr src1)]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
trivialFCode pk instr _ _ _ [x, StInd pk' mem]
- = getReg x `thenSUs` \ register1 ->
+ = getReg x `thenUs` \ register1 ->
--getNewRegNCG (registerKind register1)
- -- `thenSUs` \ tmp1 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ -- `thenUs` \ tmp1 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code2 = amodeCode amode
src2 = amodeAddr amode
- code__2 dst = let
+ code__2 dst = let
code1 = registerCode register1 dst
src1 = registerName register1 dst
- in asmParThen [code2 asmVoid,code1 asmVoid] .
+ in asmParThen [code2 asmVoid,code1 asmVoid] .
mkSeqInstrs [instr (kindToSize pk) (OpAddr src2)]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
trivialFCode pk _ _ _ instrpr [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
--getNewRegNCG (registerKind register1)
- -- `thenSUs` \ tmp1 ->
+ -- `thenUs` \ tmp1 ->
--getNewRegNCG (registerKind register2)
- -- `thenSUs` \ tmp2 ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ -- `thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
pk1 = registerKind register1
code1 = registerCode register1 st0 --tmp1
pk2 = registerKind register2
- code__2 dst = let
+ code__2 dst = let
code2 = registerCode register2 dst
src2 = registerName register2 dst
in asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr instrpr
+ mkSeqInstr instrpr
in
- returnSUs (Any pk1 code__2)
+ returnUs (Any pk1 code__2)
\end{code}
\begin{code}
-trivialUCode
- :: (Operand -> I386Instr)
+trivialUCode
+ :: (Operand -> I386Instr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialUCode instr [x] =
- getReg x `thenSUs` \ register ->
--- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+-- getNewRegNCG IntRep `thenUs` \ tmp ->
let
-- fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
- src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- instr (OpReg dst)]
- else mkSeqInstr (instr (OpReg src))
+ src = registerName register dst
+ in code . if isFixed register && dst /= src
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ instr (OpReg dst)]
+ else mkSeqInstr (instr (OpReg src))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-trivialUFCode
- :: PrimKind
+trivialUFCode
+ :: PrimRep
-> I386Instr
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialUFCode pk instr [StInd pk' mem] =
- getAmode mem `thenSUs` \ amode ->
- let
+ getAmode mem `thenUs` \ amode ->
+ let
code = amodeCode amode
src = amodeAddr amode
code__2 dst = code . mkSeqInstrs [FLD (kindToSize pk) (OpAddr src),
- instr]
+ instr]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
trivialUFCode pk instr [x] =
- getReg x `thenSUs` \ register ->
- --getNewRegNCG pk `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ --getNewRegNCG pk `thenUs` \ tmp ->
let
code__2 dst = let
code = registerCode register dst
src = registerName register dst
- in code . mkSeqInstrs [instr]
+ in code . mkSeqInstrs [instr]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
\end{code}
Absolute value on integers, mostly for gmp size check macros. Again,
\begin{code}
-absIntCode :: [StixTree] -> SUniqSM Register
+absIntCode :: [StixTree] -> UniqSM Register
absIntCode [x] =
- getReg x `thenSUs` \ register ->
- --getNewRegNCG IntKind `thenSUs` \ reg ->
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getReg x `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ reg ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let
code__2 dst = let code = registerCode register dst
src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- TEST L (OpReg dst) (OpReg dst),
- JXX GE lbl,
- NEGI L (OpReg dst),
- LABEL lbl]
- else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
- JXX GE lbl,
- NEGI L (OpReg src),
- LABEL lbl]
+ in code . if isFixed register && dst /= src
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ TEST L (OpReg dst) (OpReg dst),
+ JXX GE lbl,
+ NEGI L (OpReg dst),
+ LABEL lbl]
+ else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
+ JXX GE lbl,
+ NEGI L (OpReg src),
+ LABEL lbl]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
-
+
Simple integer coercions that don't require any code to be generated.
Here we just change the type on the register passed on up
\begin{code}
-coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
+coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
coerceIntCode pk [x] =
- getReg x `thenSUs` \ register ->
+ getReg x `thenUs` \ register ->
case register of
- Fixed reg _ code -> returnSUs (Fixed reg pk code)
- Any _ code -> returnSUs (Any pk code)
+ Fixed reg _ code -> returnUs (Fixed reg pk code)
+ Any _ code -> returnUs (Any pk code)
-coerceFltCode :: [StixTree] -> SUniqSM Register
+coerceFltCode :: [StixTree] -> UniqSM Register
coerceFltCode [x] =
- getReg x `thenSUs` \ register ->
+ getReg x `thenUs` \ register ->
case register of
- Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code)
- Any _ code -> returnSUs (Any DoubleKind code)
+ Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
+ Any _ code -> returnUs (Any DoubleRep code)
\end{code}
the original object is in memory.
\begin{code}
-chrCode :: [StixTree] -> SUniqSM Register
+chrCode :: [StixTree] -> UniqSM Register
{-
chrCode [StInd pk mem] =
- getAmode mem `thenSUs` \ amode ->
- let
+ getAmode mem `thenUs` \ amode ->
+ let
code = amodeCode amode
src = amodeAddr amode
code__2 dst = code . mkSeqInstr (MOVZX L (OpAddr src) (OpReg dst))
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
-}
chrCode [x] =
- getReg x `thenSUs` \ register ->
- --getNewRegNCG IntKind `thenSUs` \ reg ->
+ getReg x `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ reg ->
let
fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
src = registerName register dst
- in code .
- if isFixed register && src /= dst
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- AND L (OpImm (ImmInt 255)) (OpReg dst)]
- else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
+ in code .
+ if isFixed register && src /= dst
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ AND L (OpImm (ImmInt 255)) (OpReg dst)]
+ else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
point register sets.
\begin{code}
-coerceInt2FP :: PrimKind -> [StixTree] -> SUniqSM Register
-coerceInt2FP pk [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ reg ->
+coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
+coerceInt2FP pk [x] =
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
let
code = registerCode register reg
src = registerName register reg
code__2 dst = code . mkSeqInstrs [
- -- to fix: should spill instead of using R1
+ -- to fix: should spill instead of using R1
MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
FILD (kindToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
-coerceFP2Int :: [StixTree] -> SUniqSM Register
+coerceFP2Int :: [StixTree] -> UniqSM Register
coerceFP2Int [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
pk = registerKind register
- code__2 dst = let
- in code . mkSeqInstrs [
+ code__2 dst = let
+ in code . mkSeqInstrs [
FRNDINT,
FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
Some random little helpers.
\begin{code}
maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i)
+maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
| otherwise = Just (ImmInteger i)
maybeImm (StLitLbl s) = Just (ImmLit (uppBeside (uppChar '_') s))
mangleIndexTree :: StixTree -> StixTree
-mangleIndexTree (StIndex pk base (StInt i)) =
+mangleIndexTree (StIndex pk base (StInt i)) =
StPrim IntAddOp [base, off]
where
off = StInt (i * size pk)
- size :: PrimKind -> Integer
+ size :: PrimRep -> Integer
size pk = case kindToSize pk of
{B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 }
-mangleIndexTree (StIndex pk base off) =
+mangleIndexTree (StIndex pk base off) =
case pk of
- CharKind -> StPrim IntAddOp [base, off]
+ CharRep -> StPrim IntAddOp [base, off]
_ -> StPrim IntAddOp [base, off__2]
where
off__2 = StPrim SllOp [off, StInt (shift pk)]
- shift :: PrimKind -> Integer
- shift DoubleKind = 3
+ shift :: PrimRep -> Integer
+ shift DoubleRep = 3
shift _ = 2
cvtLitLit :: String -> String
-cvtLitLit "stdin" = "_IO_stdin_"
-cvtLitLit "stdout" = "_IO_stdout_"
+cvtLitLit "stdin" = "_IO_stdin_"
+cvtLitLit "stdout" = "_IO_stdout_"
cvtLitLit "stderr" = "_IO_stderr_"
-cvtLitLit s
+cvtLitLit s
| isHex s = s
| otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
- where
+ where
isHex ('0':'x':xs) = all isHexDigit xs
isHex _ = False
-- Now, where have I seen this before?
\begin{code}
-stackArgLoc = 23 :: Int -- where to stack call arguments
+stackArgLoc = 23 :: Int -- where to stack call arguments
\end{code}
\begin{code}
-getNewRegNCG :: PrimKind -> SUniqSM Reg
-getNewRegNCG pk =
- getSUnique `thenSUs` \ u ->
- returnSUs (mkReg u pk)
+getNewRegNCG :: PrimRep -> UniqSM Reg
+getNewRegNCG pk =
+ getUnique `thenUs` \ u ->
+ returnUs (mkReg u pk)
fixFPCond :: Cond -> Cond
-- on the 486 the flags set by FP compare are the unsigned ones!
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MachDesc where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import ClosureInfo(ClosureInfo)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree, StixTreeList(..))
-import Unique(Unique)
-import Unpretty(Unpretty(..))
-data AbstractC
-data CAddrMode
-data CExprMacro
-data CStmtMacro
-data MagicId
-data RegRelative
-data BasicLit
-data CLabel
-data CSeq
-data GlobalSwitch
-data RegLoc = Save StixTree | Always StixTree
-data SwitchResult
-data HeapOffset
-data PprStyle
-data PrimKind
-data PrimOp
-data SMRep
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply
-data StixTree
-type StixTreeList = [StixTree] -> [StixTree]
-data Target = Target Int (SMRep -> Int) (MagicId -> RegLoc) (PrimKind -> Int) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) ([MagicId] -> [StixTree], [MagicId] -> [StixTree], Int, Int, StixTree, StixTree, [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree])
-data Unique
-type Unpretty = CSeq
-amodeToStix :: Target -> CAddrMode -> StixTree
-amodeToStix' :: Target -> CAddrMode -> StixTree
-charLikeClosureSize :: Target -> Int
-dataHS :: Target -> StixTree
-fixedHeaderSize :: Target -> Int
-heapCheck :: Target -> StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]
-hpRel :: Target -> HeapOffset -> Int
-intLikeClosureSize :: Target -> Int
-macroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
-mkTarget :: Int -> (SMRep -> Int) -> (MagicId -> RegLoc) -> (PrimKind -> Int) -> (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> (CAddrMode -> StixTree) -> ([MagicId] -> [StixTree], [MagicId] -> [StixTree], Int, Int, StixTree, StixTree, [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> Target
-mutHS :: Target -> StixTree
-primToStix :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
-saveLoc :: Target -> MagicId -> StixTree
-sizeof :: Target -> PrimKind -> Int
-stgReg :: Target -> MagicId -> RegLoc
-varHeaderSize :: Target -> SMRep -> Int
-volatileRestores :: Target -> [MagicId] -> [StixTree]
-volatileSaves :: Target -> [MagicId] -> [StixTree]
-
% (c) The AQUA Project, Glasgow University, 1993-1995
%
-Machine- and flag- specific bits that the abstract code generator has to know about.
+Machine- and flag- specific bits that the abstract code generator has
+to know about.
No doubt there will be more...
#include "HsVersions.h"
module MachDesc (
- Target(..){-(..) for target_STRICT only-}, mkTarget, RegLoc(..),
+ Target(..){-(..) for target_STRICT only-}, mkTarget, RegLoc(..),
saveLoc,
--- targetSwitches, UNUSED FOR NOW
fixedHeaderSize, varHeaderSize, stgReg,
--- nativeOpt, UNUSED FOR NOW
sizeof, volatileSaves, volatileRestores, hpRel,
amodeToStix, amodeToStix', charLikeClosureSize,
intLikeClosureSize, mutHS, dataHS, primToStix, macroCode,
- heapCheck,
--- codeGen, underscore, fmtAsmLbl, UNUSED FOR NOW (done a diff way)
+ heapCheck
-- and, for self-sufficiency...
- AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId,
- RegRelative, CSeq, BasicLit, CLabel, GlobalSwitch,
- SwitchResult, HeapOffset, PrimOp, PprStyle,
- PrimKind, SMRep, StixTree, Unique, SplitUniqSupply,
- StixTreeList(..), SUniqSM(..), Unpretty(..)
) where
import AbsCSyn
import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
import Outputable
import OrdList ( OrdList )
-import PrimKind ( PrimKind )
import SMRep ( SMRep )
import Stix
-import SplitUniq
+import UniqSupply
import Unique
import Unpretty ( PprStyle, CSeq )
import Util
-data RegLoc = Save (StixTree) | Always (StixTree)
-
+data RegLoc = Save StixTree | Always StixTree
\end{code}
-Think of this as a big runtime class dictionary
-
+Think of this as a big runtime class dictionary:
\begin{code}
-
data Target = Target
--- (GlobalSwitch -> SwitchResult) -- switches
Int -- fixedHeaderSize
(SMRep -> Int) -- varHeaderSize
(MagicId -> RegLoc) -- stgReg
--- (StixTree -> StixTree) -- nativeOpt
- (PrimKind -> Int) -- sizeof
+ (PrimRep -> Int) -- sizeof
(HeapOffset -> Int) -- hpRel
(CAddrMode -> StixTree) -- amodeToStix
(CAddrMode -> StixTree) -- amodeToStix'
Int, -- intLikeClosureSize
StixTree, -- mutHS
StixTree, -- dataHS
- ([CAddrMode] -> PrimOp -> [CAddrMode] -> SUniqSM StixTreeList),
+ ([CAddrMode] -> PrimOp -> [CAddrMode] -> UniqSM StixTreeList),
-- primToStix
- (CStmtMacro -> [CAddrMode] -> SUniqSM StixTreeList),
+ (CStmtMacro -> [CAddrMode] -> UniqSM StixTreeList),
-- macroCode
- (StixTree -> StixTree -> StixTree -> SUniqSM StixTreeList)
+ (StixTree -> StixTree -> StixTree -> UniqSM StixTreeList)
-- heapCheck
)
-{- UNUSED: done a diff way:
- (PprStyle -> [[StixTree]] -> SUniqSM Unpretty)
- -- codeGen
-
- Bool -- underscore
- (String -> String) -- fmtAsmLbl
--}
mkTarget = Target
-{- UNUSED FOR NOW:
-targetSwitches (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = {-sw-} x
--}
-fixedHeaderSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = fhs
-varHeaderSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vhs x
-stgReg (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = reg x
-{- UNUSED FOR NOW:
-nativeOpt (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = {-opt-} x
--}
-sizeof (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = size x
+fixedHeaderSize (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = fhs
+varHeaderSize (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = vhs x
+stgReg (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = reg x
+sizeof (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = size x
-- used only for wrapper-hungry PrimOps:
-hpRel (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = hprel x
-amodeToStix (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = am x
-amodeToStix' (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = am' x
+hpRel (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = hprel x
+amodeToStix (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = am x
+amodeToStix' (Target fhs vhs reg size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = am' x
-volatileSaves (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vsave x
+volatileSaves (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = vsave x
-- used only for wrapper-hungry PrimOps:
-volatileRestores (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vrest x
-charLikeClosureSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = csz
-intLikeClosureSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = isz
-mutHS (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = mhs
-dataHS (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = dhs
-primToStix (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y z = ps x y z
-macroCode (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y = mc x y
-heapCheck (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y z = hc x y z
-{- UNUSED: done a diff way:
-codeGen (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y = cg x y
-underscore (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = us
-fmtAsmLbl (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = fmt x
--}
+volatileRestores (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x = vrest x
+charLikeClosureSize (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = csz
+intLikeClosureSize (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = isz
+mutHS (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = mhs
+dataHS (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) = dhs
+primToStix (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x y z = ps x y z
+macroCode (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x y = mc x y
+heapCheck (Target fhs vhs reg size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) ) x y z = hc x y z
\end{code}
Trees for register save locations
-
\begin{code}
-
saveLoc :: Target -> MagicId -> StixTree
-saveLoc target reg = case stgReg target reg of {Always loc -> loc; Save loc -> loc}
+saveLoc target reg = case stgReg target reg of {Always loc -> loc; Save loc -> loc}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SparcCode where
-import AbsCSyn(MagicId)
-import AsmRegAlloc(MachineCode, MachineRegisters, Reg)
-import BitSet(BitSet)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import FiniteMap(FiniteMap)
-import Maybes(Labda)
-import OrdList(OrdList)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import Stix(CodeSegment)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Addr = AddrRegReg Reg Reg | AddrRegImm Reg Imm
-data MagicId
-data Reg
-data BitSet
-data CLabel
-data CSeq
-data FiniteMap a b
-data OrdList a
-data PrimKind
-data CodeSegment
-data Cond = ALWAYS | NEVER | GEU | LU | EQ | GT | GE | GU | LT | LE | LEU | NE | NEG | POS | VC | VS
-data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq | ImmLit CSeq | LO Imm | HI Imm
-data RI = RIReg Reg | RIImm Imm
-data Size = SB | HW | UB | UHW | W | D | F | DF
-type SparcCode = OrdList SparcInstr
-data SparcInstr = LD Size Addr Reg | ST Size Reg Addr | ADD Bool Bool Reg RI Reg | SUB Bool Bool Reg RI Reg | AND Bool Reg RI Reg | ANDN Bool Reg RI Reg | OR Bool Reg RI Reg | ORN Bool Reg RI Reg | XOR Bool Reg RI Reg | XNOR Bool Reg RI Reg | SLL Reg RI Reg | SRL Reg RI Reg | SRA Reg RI Reg | SETHI Imm Reg | NOP | FABS Size Reg Reg | FADD Size Reg Reg Reg | FCMP Bool Size Reg Reg | FDIV Size Reg Reg Reg | FMOV Size Reg Reg | FMUL Size Reg Reg Reg | FNEG Size Reg Reg | FSQRT Size Reg Reg | FSUB Size Reg Reg Reg | FxTOy Size Size Reg Reg | BI Cond Bool Imm | BF Cond Bool Imm | JMP Addr | CALL Imm Int Bool | LABEL CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm]
-data SparcRegs
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-argRegs :: [Reg]
-baseRegOffset :: MagicId -> Int
-callerSaves :: MagicId -> Bool
-f0 :: Reg
-fp :: Reg
-freeRegs :: [Reg]
-g0 :: Reg
-is13Bits :: Integral a => a -> Bool
-kindToSize :: PrimKind -> Size
-o0 :: Reg
-offset :: Addr -> Int -> Labda Addr
-printLabeledCodes :: PprStyle -> [SparcInstr] -> CSeq
-reservedRegs :: [Int]
-sp :: Reg
-stgRegMap :: MagicId -> Labda Reg
-strImmLit :: [Char] -> Imm
-instance MachineCode SparcInstr
-instance MachineRegisters SparcRegs
-
module SparcCode (
Addr(..),Cond(..),Imm(..),RI(..),Size(..),
SparcCode(..),SparcInstr(..),SparcRegs,
- strImmLit, --UNUSED: strImmLab,
+ strImmLit,
printLabeledCodes,
g0, o0, f0, fp, sp, argRegs,
- freeRegs, reservedRegs,
+ freeRegs, reservedRegs
-- and, for self-sufficiency ...
- CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..),
- UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet
) where
IMPORT_Trace
import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..),
Reg(..), RegUsage(..), RegLiveness(..)
)
-import BitSet
+import BitSet
import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
-import CLabelInfo ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
-import FiniteMap
+import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
+import FiniteMap
import Maybes ( Maybe(..), maybeToBool )
import OrdList ( OrdList, mkUnitList, flattenOrdList )
-import Outputable
-import PrimKind ( PrimKind(..) )
+import Outputable
import UniqSet
import Stix
import Unpretty
| HI Imm
deriving ()
---UNUSED:strImmLab s = ImmLab (uppStr s)
strImmLit s = ImmLit (uppStr s)
data Addr = AddrRegReg Reg Reg
pprSparcReg :: FAST_INT -> Unpretty
pprSparcReg i = uppPStr
(case i of {
- ILIT( 0) -> SLIT("%g0"); ILIT( 1) -> SLIT("%g1");
+ ILIT( 0) -> SLIT("%g0"); ILIT( 1) -> SLIT("%g1");
ILIT( 2) -> SLIT("%g2"); ILIT( 3) -> SLIT("%g3");
- ILIT( 4) -> SLIT("%g4"); ILIT( 5) -> SLIT("%g5");
+ ILIT( 4) -> SLIT("%g4"); ILIT( 5) -> SLIT("%g5");
ILIT( 6) -> SLIT("%g6"); ILIT( 7) -> SLIT("%g7");
- ILIT( 8) -> SLIT("%o0"); ILIT( 9) -> SLIT("%o1");
+ ILIT( 8) -> SLIT("%o0"); ILIT( 9) -> SLIT("%o1");
ILIT(10) -> SLIT("%o2"); ILIT(11) -> SLIT("%o3");
- ILIT(12) -> SLIT("%o4"); ILIT(13) -> SLIT("%o5");
+ ILIT(12) -> SLIT("%o4"); ILIT(13) -> SLIT("%o5");
ILIT(14) -> SLIT("%o6"); ILIT(15) -> SLIT("%o7");
- ILIT(16) -> SLIT("%l0"); ILIT(17) -> SLIT("%l1");
+ ILIT(16) -> SLIT("%l0"); ILIT(17) -> SLIT("%l1");
ILIT(18) -> SLIT("%l2"); ILIT(19) -> SLIT("%l3");
- ILIT(20) -> SLIT("%l4"); ILIT(21) -> SLIT("%l5");
+ ILIT(20) -> SLIT("%l4"); ILIT(21) -> SLIT("%l5");
ILIT(22) -> SLIT("%l6"); ILIT(23) -> SLIT("%l7");
- ILIT(24) -> SLIT("%i0"); ILIT(25) -> SLIT("%i1");
+ ILIT(24) -> SLIT("%i0"); ILIT(25) -> SLIT("%i1");
ILIT(26) -> SLIT("%i2"); ILIT(27) -> SLIT("%i3");
- ILIT(28) -> SLIT("%i4"); ILIT(29) -> SLIT("%i5");
+ ILIT(28) -> SLIT("%i4"); ILIT(29) -> SLIT("%i5");
ILIT(30) -> SLIT("%i6"); ILIT(31) -> SLIT("%i7");
- ILIT(32) -> SLIT("%f0"); ILIT(33) -> SLIT("%f1");
+ ILIT(32) -> SLIT("%f0"); ILIT(33) -> SLIT("%f1");
ILIT(34) -> SLIT("%f2"); ILIT(35) -> SLIT("%f3");
- ILIT(36) -> SLIT("%f4"); ILIT(37) -> SLIT("%f5");
+ ILIT(36) -> SLIT("%f4"); ILIT(37) -> SLIT("%f5");
ILIT(38) -> SLIT("%f6"); ILIT(39) -> SLIT("%f7");
- ILIT(40) -> SLIT("%f8"); ILIT(41) -> SLIT("%f9");
+ ILIT(40) -> SLIT("%f8"); ILIT(41) -> SLIT("%f9");
ILIT(42) -> SLIT("%f10"); ILIT(43) -> SLIT("%f11");
- ILIT(44) -> SLIT("%f12"); ILIT(45) -> SLIT("%f13");
+ ILIT(44) -> SLIT("%f12"); ILIT(45) -> SLIT("%f13");
ILIT(46) -> SLIT("%f14"); ILIT(47) -> SLIT("%f15");
- ILIT(48) -> SLIT("%f16"); ILIT(49) -> SLIT("%f17");
+ ILIT(48) -> SLIT("%f16"); ILIT(49) -> SLIT("%f17");
ILIT(50) -> SLIT("%f18"); ILIT(51) -> SLIT("%f19");
- ILIT(52) -> SLIT("%f20"); ILIT(53) -> SLIT("%f21");
+ ILIT(52) -> SLIT("%f20"); ILIT(53) -> SLIT("%f21");
ILIT(54) -> SLIT("%f22"); ILIT(55) -> SLIT("%f23");
- ILIT(56) -> SLIT("%f24"); ILIT(57) -> SLIT("%f25");
+ ILIT(56) -> SLIT("%f24"); ILIT(57) -> SLIT("%f25");
ILIT(58) -> SLIT("%f26"); ILIT(59) -> SLIT("%f27");
- ILIT(60) -> SLIT("%f28"); ILIT(61) -> SLIT("%f29");
+ ILIT(60) -> SLIT("%f28"); ILIT(61) -> SLIT("%f29");
ILIT(62) -> SLIT("%f30"); ILIT(63) -> SLIT("%f31");
_ -> SLIT("very naughty sparc register")
})
asciify :: String -> Int -> Unpretty
asciify [] _ = uppStr ("\\0\"")
asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
- asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
- asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
- asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
+ asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
+ asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
+ asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
asciify (c:(cs@(d:_))) n | isDigit d =
uppBeside (uppStr (charToC c)) (asciify cs 0)
Getting the conflicts right is a bit tedious for doubles. We'd have to
add a conflict function to the MachineRegisters class, and we'd have to
-put a PrimKind in the MappedReg datatype, or use some kludge (e.g. register
+put a PrimRep in the MappedReg datatype, or use some kludge (e.g. register
64 + n is really the same as 32 + n, except that it's used for a double,
so it also conflicts with 33 + n) to deal with it. It's just not worth the
bother, so we just partition the free floating point registers into two
(ints, floats) = partition (< 32) xs
(singles, doubles) = partition (< 48) floats
singles' = map (subtract 32) singles
- doubles' = map (subtract 32) (filter even doubles)
+ doubles' = map (subtract 32) (filter even doubles)
- possibleMRegs FloatKind (SRegs _ singles _) = [ x + 32 | x <- listBS singles]
- possibleMRegs DoubleKind (SRegs _ _ doubles) = [ x + 32 | x <- listBS doubles]
+ possibleMRegs FloatRep (SRegs _ singles _) = [ x + 32 | x <- listBS singles]
+ possibleMRegs DoubleRep (SRegs _ _ doubles) = [ x + 32 | x <- listBS doubles]
possibleMRegs _ (SRegs ints _ _) = listBS ints
useMReg (SRegs ints singles doubles) n =
(singles `minusBS` singles')
(doubles `minusBS` doubles')
where
- SRegs ints' singles' doubles' = mkMRegs xs
+ SRegs ints' singles' doubles' = mkMRegs xs
freeMReg (SRegs ints singles doubles) n =
if n _LT_ ILIT(32) then SRegs (ints `unionBS` singletonBS IBOX(n)) singles doubles
else SRegs ints singles (doubles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32))))
freeMRegs (SRegs ints singles doubles) xs =
- SRegs (ints `unionBS` ints')
+ SRegs (ints `unionBS` ints')
(singles `unionBS` singles')
(doubles `unionBS` doubles')
where
- SRegs ints' singles' doubles' = mkMRegs xs
+ SRegs ints' singles' doubles' = mkMRegs xs
instance MachineCode SparcInstr where
- -- Alas, we don't do anything clever with our OrdLists
---OLD:
--- flatten = flattenOrdList
-
regUsage = sparcRegUsage
regLiveness = sparcRegLiveness
patchRegs = sparcPatchRegs
fpRel :: Int -> Addr
fpRel n = AddrRegImm fp (ImmInt (n * 4))
-kindToSize :: PrimKind -> Size
-kindToSize PtrKind = W
-kindToSize CodePtrKind = W
-kindToSize DataPtrKind = W
-kindToSize RetKind = W
-kindToSize InfoPtrKind = W
-kindToSize CostCentreKind = W
-kindToSize CharKind = UB
-kindToSize IntKind = W
-kindToSize WordKind = W
-kindToSize AddrKind = W
-kindToSize FloatKind = F
-kindToSize DoubleKind = DF
-kindToSize ArrayKind = W
-kindToSize ByteArrayKind = W
-kindToSize StablePtrKind = W
-kindToSize MallocPtrKind = W
+kindToSize :: PrimRep -> Size
+kindToSize PtrRep = W
+kindToSize CodePtrRep = W
+kindToSize DataPtrRep = W
+kindToSize RetRep = W
+kindToSize CostCentreRep = W
+kindToSize CharRep = UB
+kindToSize IntRep = W
+kindToSize WordRep = W
+kindToSize AddrRep = W
+kindToSize FloatRep = F
+kindToSize DoubleRep = DF
+kindToSize ArrayRep = W
+kindToSize ByteArrayRep = W
+kindToSize StablePtrRep = W
+kindToSize MallocPtrRep = W
\end{code}
lookup lbl = case lookupFM env lbl of
Just regs -> regs
Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
- " in future?") emptyUniqSet
+ " in future?") emptyUniqSet
\end{code}
(Okay, just for chrCode of a fetch.)
\begin{code}
-
-#ifdef __GLASGOW_HASKELL__
-
{-# SPECIALIZE
is13Bits :: Int -> Bool
#-}
is13Bits :: Integer -> Bool
#-}
-#endif
-
is13Bits :: Integral a => a -> Bool
is13Bits x = x >= -4096 && x < 4096
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SparcDesc where
-import AbsCSyn(MagicId)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data MagicId
-data SwitchResult
-data RegLoc
-data PprStyle
-data PrimKind
-data SMRep
-data StixTree
-mkSparc :: Bool -> (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char])
-
#include "HsVersions.h"
module SparcDesc (
- mkSparc,
+ mkSparc
-- and assorted nonsense referenced by the class methods
-
- PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult
-
) where
import AbsCSyn
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..),
RegLiveness(..), RegUsage(..), FutureLive(..)
)
-import CLabelInfo ( CLabel )
+import CLabel ( CLabel )
import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
import HeapOffs ( hpRelToInt )
import MachDesc
import Maybes ( Maybe(..) )
import OrdList
import Outputable
-import PrimKind ( PrimKind(..) )
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import SparcCode
import SparcGen ( sparcCodeGen )
import Stix
import StixMacro
import StixPrim
-import SplitUniq
-import Unique
+import UniqSupply
import Util
-
\end{code}
Header sizes depend only on command-line options, not on the target
StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
BaseReg -> sStLitLbl SLIT("MainRegTable")
- Hp -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo"))
- HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+4"))
- TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*4)])
- where
- r2 = VanillaReg PtrKind ILIT(2)
+ Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo"))
+ HpLim -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo+4"))
+ TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, StInt (1*4)])
+ where
+ r2 = VanillaReg PtrRep ILIT(2)
infoptr = case sparcReg switches r2 of
Always tree -> tree
Save _ -> StReg (StixMagicId r2)
baseLoc = case stgRegMap BaseReg of
Just _ -> StReg (StixMagicId BaseReg)
Nothing -> sStLitLbl SLIT("MainRegTable")
- offset = baseRegOffset x
-
+ offset = baseRegOffset x
+
\end{code}
Sizes in bytes.
\begin{code}
-vsaves switches vols =
+vsaves switches vols =
map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
where
- save x = StAssign (kindFromMagicId x) loc reg
+ save x = StAssign (kindFromMagicId x) loc reg
where reg = StReg (StixMagicId x)
loc = case sparcReg switches x of
Save loc -> loc
Always loc -> panic "vsaves"
-vrests switches vols =
- map restore ((filter callerSaves)
+vrests switches vols =
+ map restore ((filter callerSaves)
([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols))
where
- restore x = StAssign (kindFromMagicId x) reg loc
+ restore x = StAssign (kindFromMagicId x) reg loc
where reg = StReg (StixMagicId x)
loc = case sparcReg switches x of
Save loc -> loc
charLikeSize, intLikeSize :: Target -> Int
-charLikeSize target =
- size PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
+charLikeSize target =
+ size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
-intLikeSize target =
- size PtrKind * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
+intLikeSize target =
+ size PtrRep * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
mhs switches = StInt (toInteger words)
- where
+ where
words = fhs switches + vhs switches (MuTupleRep 0)
dhs switches = StInt (toInteger words)
- where
+ where
words = fhs switches + vhs switches (DataRep 0)
\end{code}
mkSparc :: Bool
-> (GlobalSwitch -> SwitchResult)
-> (Target,
- (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen
+ (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen
Bool, -- underscore
(String -> String)) -- fmtAsmLbl
-mkSparc decentOS switches =
+mkSparc decentOS switches =
let
fhs' = fhs switches
vhs' = vhs switches
sparcReg' = sparcReg switches
vsaves' = vsaves switches
vrests' = vrests switches
- hprel = hpRelToInt target
- as = amodeCode target
- as' = amodeCode' target
+ hprel = hpRelToInt target
+ as = amodeCode target
+ as' = amodeCode' target
csz = charLikeSize target
isz = intLikeSize target
mhs' = mhs switches
dhs' = dhs switches
ps = genPrimCode target
mc = genMacroCode target
- hc = doHeapCheck --UNUSED NOW: target
+ hc = doHeapCheck
target = mkTarget {-switches-} fhs' vhs' sparcReg' {-id-} size
hprel as as'
(vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SparcGen where
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-data CSeq
-data PprStyle
-data StixTree
-sparcCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
-
IMPORT_Trace
import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos,
- Reg(..), RegLiveness(..), RegUsage(..),
+ Reg(..), RegLiveness(..), RegUsage(..),
FutureLive(..), MachineRegisters(..), MachineCode(..)
)
-import CLabelInfo ( CLabel, isAsmTemp )
+import CLabel ( CLabel, isAsmTemp )
import SparcCode {- everything -}
import MachDesc
import Maybes ( maybeToBool, Maybe(..) )
import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
import Outputable
-import PrimKind ( PrimKind(..), isFloatingKind )
import SparcDesc
import Stix
-import SplitUniq
-import Unique
+import UniqSupply
import Pretty
import Unpretty
import Util
type CodeBlock a = (OrdList a -> OrdList a)
-
\end{code}
%************************************************************************
\begin{code}
-sparcCodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
-sparcCodeGen sty trees =
- mapSUs genSparcCode trees `thenSUs` \ dynamicCodes ->
+sparcCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
+sparcCodeGen sty trees =
+ mapUs genSparcCode trees `thenUs` \ dynamicCodes ->
let
staticCodes = scheduleSparcCode dynamicCodes
pretty = printLabeledCodes sty staticCodes
in
- returnSUs pretty
+ returnUs pretty
\end{code}
\begin{code}
-data Register
- = Fixed Reg PrimKind (CodeBlock SparcInstr)
- | Any PrimKind (Reg -> (CodeBlock SparcInstr))
+data Register
+ = Fixed Reg PrimRep (CodeBlock SparcInstr)
+ | Any PrimRep (Reg -> (CodeBlock SparcInstr))
registerCode :: Register -> Reg -> CodeBlock SparcInstr
registerCode (Fixed _ _ code) reg = code
registerName (Fixed reg _ _) _ = reg
registerName (Any _ _) reg = reg
-registerKind :: Register -> PrimKind
+registerKind :: Register -> PrimRep
registerKind (Fixed _ pk _) = pk
registerKind (Any pk _) = pk
asmParThen :: [SparcCode] -> (CodeBlock SparcInstr)
asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-returnInstr :: SparcInstr -> SUniqSM (CodeBlock SparcInstr)
-returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
+returnInstr :: SparcInstr -> UniqSM (CodeBlock SparcInstr)
+returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-returnInstrs :: [SparcInstr] -> SUniqSM (CodeBlock SparcInstr)
-returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
+returnInstrs :: [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
+returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> SUniqSM (CodeBlock SparcInstr)
-returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
+returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
mkSeqInstr :: SparcInstr -> (CodeBlock SparcInstr)
mkSeqInstr instr code = mkSeqList (asmInstr instr) code
\begin{code}
-genSparcCode :: [StixTree] -> SUniqSM (SparcCode)
+genSparcCode :: [StixTree] -> UniqSM (SparcCode)
genSparcCode trees =
- mapSUs getCode trees `thenSUs` \ blocks ->
- returnSUs (foldr (.) id blocks asmVoid)
+ mapUs getCode trees `thenUs` \ blocks ->
+ returnUs (foldr (.) id blocks asmVoid)
\end{code}
\begin{code}
-getCode
+getCode
:: StixTree -- a stix statement
- -> SUniqSM (CodeBlock SparcInstr)
+ -> UniqSM (CodeBlock SparcInstr)
getCode (StSegment seg) = returnInstr (SEGMENT seg)
getCode (StAssign pk dst src)
- | isFloatingKind pk = assignFltCode pk dst src
+ | isFloatingRep pk = assignFltCode pk dst src
| otherwise = assignIntCode pk dst src
getCode (StLabel lab) = returnInstr (LABEL lab)
getCode (StFunBegin lab) = returnInstr (LABEL lab)
-getCode (StFunEnd lab) = returnSUs id
+getCode (StFunEnd lab) = returnUs id
getCode (StJump arg) = genJump arg
-getCode (StFallThrough lbl) = returnSUs id
+getCode (StFallThrough lbl) = returnUs id
getCode (StCondJump lbl arg) = genCondJump lbl arg
-getCode (StData kind args) =
- mapAndUnzipSUs getData args `thenSUs` \ (codes, imms) ->
- returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
- (foldr1 (.) codes xs))
+getCode (StData kind args) =
+ mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
+ returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
+ (foldr1 (.) codes xs))
where
- getData :: StixTree -> SUniqSM (CodeBlock SparcInstr, Imm)
- getData (StInt i) = returnSUs (id, ImmInteger i)
-#if __GLASGOW_HASKELL__ >= 23
--- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : _showRational 30 d))
- -- yurgh (WDP 94/12)
- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d)))
-#else
- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : show d))
-#endif
- getData (StLitLbl s) = returnSUs (id, ImmLab s)
- getData (StLitLit s) = returnSUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
- getData (StString s) =
- getUniqLabelNCG `thenSUs` \ lbl ->
- returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
- getData (StCLbl l) = returnSUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
+ getData :: StixTree -> UniqSM (CodeBlock SparcInstr, Imm)
+ getData (StInt i) = returnUs (id, ImmInteger i)
+ getData (StDouble d) = returnUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d)))
+ getData (StLitLbl s) = returnUs (id, ImmLab s)
+ getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
+ getData (StString s) =
+ getUniqLabelNCG `thenUs` \ lbl ->
+ returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
+ getData (StCLbl l) = returnUs (id, ImmCLbl l)
+
+getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
getCode (StComment s) = returnInstr (COMMENT s)
\begin{code}
-getReg :: StixTree -> SUniqSM Register
+getReg :: StixTree -> UniqSM Register
getReg (StReg (StixMagicId stgreg)) =
case stgRegMap stgreg of
- Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
+ Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
-- cannae be Nothing
-getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
+getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
getReg (StDouble d) =
- getUniqLabelNCG `thenSUs` \ lbl ->
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getUniqLabelNCG `thenUs` \ lbl ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
-#if __GLASGOW_HASKELL__ >= 23
--- DATA DF [strImmLit ('0' : 'r' : (_showRational 30 d))],
DATA DF [strImmLit ('0' : 'r' : ppShow 80 (ppRational d))],
-#else
- DATA DF [strImmLit ('0' : 'r' : (show d))],
-#endif
SEGMENT TextSegment,
SETHI (HI (ImmCLbl lbl)) tmp,
LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
in
- returnSUs (Any DoubleKind code)
+ returnUs (Any DoubleRep code)
getReg (StString s) =
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
SETHI (HI (ImmCLbl lbl)) dst,
OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
SETHI (HI (ImmCLbl lbl)) dst,
OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
where
xs = _UNPK_ (_TAIL_ s)
getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
-getReg (StCall fn kind args) =
- genCCall fn kind args `thenSUs` \ call ->
- returnSUs (Fixed reg kind call)
+getReg (StCall fn kind args) =
+ genCCall fn kind args `thenUs` \ call ->
+ returnUs (Fixed reg kind call)
where
- reg = if isFloatingKind kind then f0 else o0
+ reg = if isFloatingRep kind then f0 else o0
-getReg (StPrim primop args) =
+getReg (StPrim primop args) =
case primop of
CharGtOp -> condIntReg GT args
IntAddOp -> trivialCode (ADD False False) args
IntSubOp -> trivialCode (SUB False False) args
- IntMulOp -> call SLIT(".umul") IntKind
- IntQuotOp -> call SLIT(".div") IntKind
- IntRemOp -> call SLIT(".rem") IntKind
+ IntMulOp -> call SLIT(".umul") IntRep
+ IntQuotOp -> call SLIT(".div") IntRep
+ IntRemOp -> call SLIT(".rem") IntRep
IntNegOp -> trivialUCode (SUB False False g0) args
IntAbsOp -> absIntCode args
-
+
AndOp -> trivialCode (AND False) args
OrOp -> trivialCode (OR False) args
NotOp -> trivialUCode (XNOR False g0) args
ISllOp -> panic "SparcGen:isll"
ISraOp -> panic "SparcGen:isra"
ISrlOp -> panic "SparcGen:isrl"
-
+
IntGtOp -> condIntReg GT args
IntGeOp -> condIntReg GE args
IntEqOp -> condIntReg EQ args
IntNeOp -> condIntReg NE args
IntLtOp -> condIntReg LT args
IntLeOp -> condIntReg LE args
-
+
WordGtOp -> condIntReg GU args
WordGeOp -> condIntReg GEU args
WordEqOp -> condIntReg EQ args
AddrLtOp -> condIntReg LU args
AddrLeOp -> condIntReg LEU args
- FloatAddOp -> trivialFCode FloatKind FADD args
- FloatSubOp -> trivialFCode FloatKind FSUB args
- FloatMulOp -> trivialFCode FloatKind FMUL args
- FloatDivOp -> trivialFCode FloatKind FDIV args
- FloatNegOp -> trivialUFCode FloatKind (FNEG F) args
+ FloatAddOp -> trivialFCode FloatRep FADD args
+ FloatSubOp -> trivialFCode FloatRep FSUB args
+ FloatMulOp -> trivialFCode FloatRep FMUL args
+ FloatDivOp -> trivialFCode FloatRep FDIV args
+ FloatNegOp -> trivialUFCode FloatRep (FNEG F) args
FloatGtOp -> condFltReg GT args
FloatGeOp -> condFltReg GE args
FloatLtOp -> condFltReg LT args
FloatLeOp -> condFltReg LE args
- FloatExpOp -> promoteAndCall SLIT("exp") DoubleKind
- FloatLogOp -> promoteAndCall SLIT("log") DoubleKind
- FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleKind
-
- FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind
- FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind
- FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind
-
- FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind
- FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind
- FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind
-
- FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind
- FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind
- FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind
-
- FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind
-
- DoubleAddOp -> trivialFCode DoubleKind FADD args
- DoubleSubOp -> trivialFCode DoubleKind FSUB args
- DoubleMulOp -> trivialFCode DoubleKind FMUL args
- DoubleDivOp -> trivialFCode DoubleKind FDIV args
- DoubleNegOp -> trivialUFCode DoubleKind (FNEG DF) args
-
+ FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
+ FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
+ FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleRep
+
+ FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
+ FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
+ FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
+
+ FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
+ FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
+ FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
+
+ FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
+ FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
+ FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
+
+ FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
+
+ DoubleAddOp -> trivialFCode DoubleRep FADD args
+ DoubleSubOp -> trivialFCode DoubleRep FSUB args
+ DoubleMulOp -> trivialFCode DoubleRep FMUL args
+ DoubleDivOp -> trivialFCode DoubleRep FDIV args
+ DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) args
+
DoubleGtOp -> condFltReg GT args
DoubleGeOp -> condFltReg GE args
DoubleEqOp -> condFltReg EQ args
DoubleLtOp -> condFltReg LT args
DoubleLeOp -> condFltReg LE args
- DoubleExpOp -> call SLIT("exp") DoubleKind
- DoubleLogOp -> call SLIT("log") DoubleKind
- DoubleSqrtOp -> call SLIT("sqrt") DoubleKind
-
- DoubleSinOp -> call SLIT("sin") DoubleKind
- DoubleCosOp -> call SLIT("cos") DoubleKind
- DoubleTanOp -> call SLIT("tan") DoubleKind
-
- DoubleAsinOp -> call SLIT("asin") DoubleKind
- DoubleAcosOp -> call SLIT("acos") DoubleKind
- DoubleAtanOp -> call SLIT("atan") DoubleKind
-
- DoubleSinhOp -> call SLIT("sinh") DoubleKind
- DoubleCoshOp -> call SLIT("cosh") DoubleKind
- DoubleTanhOp -> call SLIT("tanh") DoubleKind
-
- DoublePowerOp -> call SLIT("pow") DoubleKind
-
- OrdOp -> coerceIntCode IntKind args
+ DoubleExpOp -> call SLIT("exp") DoubleRep
+ DoubleLogOp -> call SLIT("log") DoubleRep
+ DoubleSqrtOp -> call SLIT("sqrt") DoubleRep
+
+ DoubleSinOp -> call SLIT("sin") DoubleRep
+ DoubleCosOp -> call SLIT("cos") DoubleRep
+ DoubleTanOp -> call SLIT("tan") DoubleRep
+
+ DoubleAsinOp -> call SLIT("asin") DoubleRep
+ DoubleAcosOp -> call SLIT("acos") DoubleRep
+ DoubleAtanOp -> call SLIT("atan") DoubleRep
+
+ DoubleSinhOp -> call SLIT("sinh") DoubleRep
+ DoubleCoshOp -> call SLIT("cosh") DoubleRep
+ DoubleTanhOp -> call SLIT("tanh") DoubleRep
+
+ DoublePowerOp -> call SLIT("pow") DoubleRep
+
+ OrdOp -> coerceIntCode IntRep args
ChrOp -> chrCode args
-
+
Float2IntOp -> coerceFP2Int args
- Int2FloatOp -> coerceInt2FP FloatKind args
+ Int2FloatOp -> coerceInt2FP FloatRep args
Double2IntOp -> coerceFP2Int args
- Int2DoubleOp -> coerceInt2FP DoubleKind args
-
- Double2FloatOp -> trivialUFCode FloatKind (FxTOy DF F) args
- Float2DoubleOp -> trivialUFCode DoubleKind (FxTOy F DF) args
+ Int2DoubleOp -> coerceInt2FP DoubleRep args
+
+ Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) args
+ Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) args
where
call fn pk = getReg (StCall fn pk args)
promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
where
- promote x = StPrim Float2DoubleOp [x]
+ promote x = StPrim Float2DoubleOp [x]
getReg (StInd pk mem) =
- getAmode mem `thenSUs` \ amode ->
- let
+ getAmode mem `thenUs` \ amode ->
+ let
code = amodeCode amode
src = amodeAddr amode
size = kindToSize pk
code__2 dst = code . mkSeqInstr (LD size src dst)
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
getReg (StInt i)
- | is13Bits i =
+ | is13Bits i =
let
src = ImmInt (fromInteger i)
code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
in
- returnSUs (Any IntKind code)
+ returnUs (Any IntRep code)
getReg leaf
| maybeToBool imm =
let
code dst = mkSeqInstrs [
- SETHI (HI imm__2) dst,
+ SETHI (HI imm__2) dst,
OR False dst (RIImm (LO imm__2)) dst]
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
\begin{code}
-getAmode :: StixTree -> SUniqSM Amode
+getAmode :: StixTree -> UniqSM Amode
getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
getAmode (StPrim IntSubOp [x, StInt i])
| is13Bits (-i) =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg x `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg x `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnSUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
| is13Bits i =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg x `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg x `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnSUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, y]) =
- getNewRegNCG PtrKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
+ getNewRegNCG PtrRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
let
code1 = registerCode register1 tmp1 asmVoid
reg1 = registerName register1 tmp1
reg2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2]
in
- returnSUs (Amode (AddrRegReg reg1 reg2) code__2)
+ returnUs (Amode (AddrRegReg reg1 reg2) code__2)
getAmode leaf
| maybeToBool imm =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
let
code = mkSeqInstr (SETHI (HI imm__2) tmp)
in
- returnSUs (Amode (AddrRegImm tmp (LO imm__2)) code)
+ returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
getAmode other =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg other `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg other `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt 0
in
- returnSUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
\end{code}
\begin{code}
-getCallArg
+getCallArg
:: ([Reg],Int) -- Argument registers and stack offset (accumulator)
-> StixTree -- Current argument
- -> SUniqSM (([Reg],Int), CodeBlock SparcInstr) -- Updated accumulator and code
+ -> UniqSM (([Reg],Int), CodeBlock SparcInstr) -- Updated accumulator and code
-- We have to use up all of our argument registers first.
-getCallArg (dst:dsts, offset) arg =
- getReg arg `thenSUs` \ register ->
+getCallArg (dst:dsts, offset) arg =
+ getReg arg `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
+ `thenUs` \ tmp ->
let
- reg = if isFloatingKind pk then tmp else dst
+ reg = if isFloatingRep pk then tmp else dst
code = registerCode register reg
src = registerName register reg
pk = registerKind register
in
- returnSUs (case pk of
- DoubleKind ->
+ returnUs (case pk of
+ DoubleRep ->
case dsts of
[] -> (([], offset + 1), code . mkSeqInstrs [
-- conveniently put the second part in the right stack
ST DF src (spRel (offset - 1)),
LD W (spRel (offset - 1)) dst])
(dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
- ST DF src (spRel (-2)),
- LD W (spRel (-2)) dst,
+ ST DF src (spRel (-2)),
+ LD W (spRel (-2)) dst,
LD W (spRel (-1)) dst__2])
- FloatKind -> ((dsts, offset), code . mkSeqInstrs [
+ FloatRep -> ((dsts, offset), code . mkSeqInstrs [
ST F src (spRel (-2)),
LD W (spRel (-2)) dst])
- _ -> ((dsts, offset), if isFixed register then
+ _ -> ((dsts, offset), if isFixed register then
code . mkSeqInstr (OR False g0 (RIReg src) dst)
else code))
-- Once we have run out of argument registers, we move to the stack
-getCallArg ([], offset) arg =
- getReg arg `thenSUs` \ register ->
+getCallArg ([], offset) arg =
+ getReg arg `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
- let
+ `thenUs` \ tmp ->
+ let
code = registerCode register tmp
src = registerName register tmp
pk = registerKind register
sz = kindToSize pk
- words = if pk == DoubleKind then 2 else 1
+ words = if pk == DoubleRep then 2 else 1
in
- returnSUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
+ returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
\end{code}
\begin{code}
-getCondition :: StixTree -> SUniqSM Condition
+getCondition :: StixTree -> UniqSM Condition
-getCondition (StPrim primop args) =
+getCondition (StPrim primop args) =
case primop of
CharGtOp -> condIntCode GT args
IntNeOp -> condIntCode NE args
IntLtOp -> condIntCode LT args
IntLeOp -> condIntCode LE args
-
+
WordGtOp -> condIntCode GU args
WordGeOp -> condIntCode GEU args
WordEqOp -> condIntCode EQ args
\begin{code}
-condIntCode, condFltCode :: Cond -> [StixTree] -> SUniqSM Condition
+condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
condIntCode cond [x, StInt y]
| is13Bits y =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
- code = registerCode register tmp
- src1 = registerName register tmp
+ code = registerCode register tmp
+ src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
- code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
+ code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
condIntCode cond [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
mkSeqInstr (SUB False True src1 (RIReg src2) g0)
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
condFltCode cond [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
getNewRegNCG (registerKind register1)
- `thenSUs` \ tmp1 ->
+ `thenUs` \ tmp1 ->
getNewRegNCG (registerKind register2)
- `thenSUs` \ tmp2 ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ `thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
promote x = asmInstr (FxTOy F DF x tmp)
code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 =
+ code__2 =
if pk1 == pk2 then
asmParThen [code1 asmVoid, code2 asmVoid] .
mkSeqInstr (FCMP True (kindToSize pk1) src1 src2)
- else if pk1 == FloatKind then
+ else if pk1 == FloatRep then
asmParThen [code1 (promote src1), code2 asmVoid] .
mkSeqInstr (FCMP True DF tmp src2)
else
- asmParThen [code1 asmVoid, code2 (promote src2)] .
+ asmParThen [code1 asmVoid, code2 (promote src2)] .
mkSeqInstr (FCMP True DF src1 tmp)
in
- returnSUs (Condition True cond code__2)
+ returnUs (Condition True cond code__2)
\end{code}
\begin{code}
-condIntReg :: Cond -> [StixTree] -> SUniqSM Register
+condIntReg :: Cond -> [StixTree] -> UniqSM Register
condIntReg EQ [x, StInt 0] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstrs [
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstrs [
SUB False True g0 (RIReg src) g0,
SUB True False g0 (RIImm (ImmInt (-1))) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
condIntReg EQ [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
SUB False True g0 (RIReg dst) g0,
SUB True False g0 (RIImm (ImmInt (-1))) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
condIntReg NE [x, StInt 0] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- let
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstrs [
SUB False True g0 (RIReg src) g0,
ADD True False g0 (RIImm (ImmInt 0)) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
condIntReg NE [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
XOR False src1 (RIReg src2) dst,
SUB False True g0 (RIReg dst) g0,
ADD True False g0 (RIImm (ImmInt 0)) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
condIntReg cond args =
- getUniqLabelNCG `thenSUs` \ lbl1 ->
- getUniqLabelNCG `thenSUs` \ lbl2 ->
- condIntCode cond args `thenSUs` \ condition ->
+ getUniqLabelNCG `thenUs` \ lbl1 ->
+ getUniqLabelNCG `thenUs` \ lbl2 ->
+ condIntCode cond args `thenUs` \ condition ->
let
- code = condCode condition
- cond = condName condition
- code__2 dst = code . mkSeqInstrs [
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = code . mkSeqInstrs [
BI cond False (ImmCLbl lbl1), NOP,
OR False g0 (RIImm (ImmInt 0)) dst,
BI ALWAYS False (ImmCLbl lbl2), NOP,
OR False g0 (RIImm (ImmInt 1)) dst,
LABEL lbl2]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-condFltReg :: Cond -> [StixTree] -> SUniqSM Register
+condFltReg :: Cond -> [StixTree] -> UniqSM Register
condFltReg cond args =
- getUniqLabelNCG `thenSUs` \ lbl1 ->
- getUniqLabelNCG `thenSUs` \ lbl2 ->
- condFltCode cond args `thenSUs` \ condition ->
+ getUniqLabelNCG `thenUs` \ lbl1 ->
+ getUniqLabelNCG `thenUs` \ lbl2 ->
+ condFltCode cond args `thenUs` \ condition ->
let
code = condCode condition
cond = condName condition
OR False g0 (RIImm (ImmInt 1)) dst,
LABEL lbl2]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
some of the register transfers will go away, because we can use the destination
register to complete the code generation for the right hand side. This only
fails when the right hand side is forced into a fixed register (e.g. the result
-of a call).
+of a call).
\begin{code}
-assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr)
+assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
assignIntCode pk (StInd _ dst) src =
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode dst `thenSUs` \ amode ->
- getReg src `thenSUs` \ register ->
- let
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getReg src `thenUs` \ register ->
+ let
code1 = amodeCode amode asmVoid
dst__2 = amodeAddr amode
code2 = registerCode register tmp asmVoid
sz = kindToSize pk
code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
in
- returnSUs code__2
+ returnUs code__2
assignIntCode pk dst src =
- getReg dst `thenSUs` \ register1 ->
- getReg src `thenSUs` \ register2 ->
- let
+ getReg dst `thenUs` \ register1 ->
+ getReg src `thenUs` \ register2 ->
+ let
dst__2 = registerName register1 g0
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
- code__2 = if isFixed register2 then
+ code__2 = if isFixed register2 then
code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
else code
in
- returnSUs code__2
+ returnUs code__2
-assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr)
+assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
assignFltCode pk (StInd _ dst) src =
- getNewRegNCG pk `thenSUs` \ tmp ->
- getAmode dst `thenSUs` \ amode ->
- getReg src `thenSUs` \ register ->
- let
+ getNewRegNCG pk `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getReg src `thenUs` \ register ->
+ let
sz = kindToSize pk
dst__2 = amodeAddr amode
pk__2 = registerKind register
sz__2 = kindToSize pk__2
- code__2 = asmParThen [code1, code2] .
- if pk == pk__2 then
+ code__2 = asmParThen [code1, code2] .
+ if pk == pk__2 then
mkSeqInstr (ST sz src__2 dst__2)
else
mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
in
- returnSUs code__2
+ returnUs code__2
assignFltCode pk dst src =
- getReg dst `thenSUs` \ register1 ->
- getReg src `thenSUs` \ register2 ->
+ getReg dst `thenUs` \ register1 ->
+ getReg src `thenUs` \ register2 ->
getNewRegNCG (registerKind register2)
- `thenSUs` \ tmp ->
- let
+ `thenUs` \ tmp ->
+ let
sz = kindToSize pk
dst__2 = registerName register1 g0 -- must be Fixed
else if isFixed register2 then code . mkSeqInstr (FMOV sz src__2 dst__2)
else code
in
- returnSUs code__2
+ returnUs code__2
-\end{code}
+\end{code}
Generating an unconditional branch. We accept two types of targets:
an immediate CLabel or a tree that gets evaluated into a register.
\begin{code}
-genJump
+genJump
:: StixTree -- the branch target
- -> SUniqSM (CodeBlock SparcInstr)
+ -> UniqSM (CodeBlock SparcInstr)
-genJump (StCLbl lbl)
+genJump (StCLbl lbl)
| isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
| otherwise = returnInstrs [CALL target 0 True, NOP]
where
target = ImmCLbl lbl
genJump tree =
- getReg tree `thenSUs` \ register ->
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getReg tree `thenUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
let
code = registerCode register tmp
target = registerName register tmp
\begin{code}
-genCondJump
+genCondJump
:: CLabel -- the branch target
-> StixTree -- the condition on which to branch
- -> SUniqSM (CodeBlock SparcInstr)
+ -> UniqSM (CodeBlock SparcInstr)
-genCondJump lbl bool =
- getCondition bool `thenSUs` \ condition ->
+genCondJump lbl bool =
+ getCondition bool `thenUs` \ condition ->
let
code = condCode condition
cond = condName condition
- target = ImmCLbl lbl
+ target = ImmCLbl lbl
in
if condFloat condition then
returnSeq code [NOP, BF cond False target, NOP]
genCCall
:: FAST_STRING -- function to call
- -> PrimKind -- type of the result
+ -> PrimRep -- type of the result
-> [StixTree] -- arguments (of mixed type)
- -> SUniqSM (CodeBlock SparcInstr)
+ -> UniqSM (CodeBlock SparcInstr)
genCCall fn kind args =
- mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
- `thenSUs` \ ((unused,_), argCode) ->
+ mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
+ `thenUs` \ ((unused,_), argCode) ->
let
nRegs = length argRegs - length unused
call = CALL fn__2 nRegs False
'.' -> ImmLit (uppPStr fn)
_ -> ImmLab (uppPStr fn)
- mapAccumLNCG f b [] = returnSUs (b, [])
- mapAccumLNCG f b (x:xs) =
- f b x `thenSUs` \ (b__2, x__2) ->
- mapAccumLNCG f b__2 xs `thenSUs` \ (b__3, xs__2) ->
- returnSUs (b__3, x__2:xs__2)
+ mapAccumLNCG f b [] = returnUs (b, [])
+ mapAccumLNCG f b (x:xs) =
+ f b x `thenUs` \ (b__2, x__2) ->
+ mapAccumLNCG f b__2 xs `thenUs` \ (b__3, xs__2) ->
+ returnUs (b__3, x__2:xs__2)
\end{code}
\begin{code}
-trivialCode
- :: (Reg -> RI -> Reg -> SparcInstr)
+trivialCode
+ :: (Reg -> RI -> Reg -> SparcInstr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialCode instr [x, StInt y]
| is13Bits y =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
trivialCode instr [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
code__2 dst = asmParThen [code1, code2] .
mkSeqInstr (instr src1 (RIReg src2) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-trivialFCode
- :: PrimKind
- -> (Size -> Reg -> Reg -> Reg -> SparcInstr)
- -> [StixTree]
- -> SUniqSM Register
+trivialFCode
+ :: PrimRep
+ -> (Size -> Reg -> Reg -> Reg -> SparcInstr)
+ -> [StixTree]
+ -> UniqSM Register
trivialFCode pk instr [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
getNewRegNCG (registerKind register1)
- `thenSUs` \ tmp1 ->
+ `thenUs` \ tmp1 ->
getNewRegNCG (registerKind register2)
- `thenSUs` \ tmp2 ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ `thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
promote x = asmInstr (FxTOy F DF x tmp)
if pk1 == pk2 then
asmParThen [code1 asmVoid, code2 asmVoid] .
mkSeqInstr (instr (kindToSize pk) src1 src2 dst)
- else if pk1 == FloatKind then
+ else if pk1 == FloatRep then
asmParThen [code1 (promote src1), code2 asmVoid] .
mkSeqInstr (instr DF tmp src2 dst)
else
asmParThen [code1 asmVoid, code2 (promote src2)] .
mkSeqInstr (instr DF src1 tmp dst)
in
- returnSUs (Any (if pk1 == pk2 then pk1 else DoubleKind) code__2)
+ returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
\end{code}
\begin{code}
-trivialUCode
- :: (RI -> Reg -> SparcInstr)
+trivialUCode
+ :: (RI -> Reg -> SparcInstr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialUCode instr [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-trivialUFCode
- :: PrimKind
- -> (Reg -> Reg -> SparcInstr)
+trivialUFCode
+ :: PrimRep
+ -> (Reg -> Reg -> SparcInstr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialUFCode pk instr [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG pk `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG pk `thenUs` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr src dst)
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
\end{code}
\begin{code}
-absIntCode :: [StixTree] -> SUniqSM Register
+absIntCode :: [StixTree] -> UniqSM Register
absIntCode [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ reg ->
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let
code = registerCode register reg
src = registerName register reg
code__2 dst = code . mkSeqInstrs [
- SUB False True g0 (RIReg src) dst,
- BI GE False (ImmCLbl lbl), NOP,
- OR False g0 (RIReg src) dst,
- LABEL lbl]
+ SUB False True g0 (RIReg src) dst,
+ BI GE False (ImmCLbl lbl), NOP,
+ OR False g0 (RIReg src) dst,
+ LABEL lbl]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
-
+
Simple integer coercions that don't require any code to be generated.
Here we just change the type on the register passed on up
\begin{code}
-coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
+coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
coerceIntCode pk [x] =
- getReg x `thenSUs` \ register ->
+ getReg x `thenUs` \ register ->
case register of
- Fixed reg _ code -> returnSUs (Fixed reg pk code)
- Any _ code -> returnSUs (Any pk code)
+ Fixed reg _ code -> returnUs (Fixed reg pk code)
+ Any _ code -> returnUs (Any pk code)
\end{code}
\begin{code}
-chrCode :: [StixTree] -> SUniqSM Register
+chrCode :: [StixTree] -> UniqSM Register
chrCode [StInd pk mem] =
- getAmode mem `thenSUs` \ amode ->
- let
+ getAmode mem `thenUs` \ amode ->
+ let
code = amodeCode amode
src = amodeAddr amode
srcOff = offset src 3
code . mkSeqInstr (LD UB src__2 dst)
else
code . mkSeqInstrs [
- LD (kindToSize pk) src dst,
+ LD (kindToSize pk) src dst,
AND False dst (RIImm (ImmInt 255)) dst]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
chrCode [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ reg ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
let
code = registerCode register reg
src = registerName register reg
code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
\begin{code}
-coerceInt2FP :: PrimKind -> [StixTree] -> SUniqSM Register
-coerceInt2FP pk [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ reg ->
+coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
+coerceInt2FP pk [x] =
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
let
code = registerCode register reg
src = registerName register reg
LD W (spRel (-2)) dst,
FxTOy W (kindToSize pk) dst dst]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
-coerceFP2Int :: [StixTree] -> SUniqSM Register
+coerceFP2Int :: [StixTree] -> UniqSM Register
coerceFP2Int [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ reg ->
- getNewRegNCG FloatKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
+ getNewRegNCG FloatRep `thenUs` \ tmp ->
let
code = registerCode register reg
src = registerName register reg
ST W tmp (spRel (-2)),
LD W (spRel (-2)) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
\begin{code}
maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i)
+maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
| otherwise = Just (ImmInteger i)
maybeImm (StLitLbl s) = Just (ImmLab s)
mangleIndexTree :: StixTree -> StixTree
-mangleIndexTree (StIndex pk base (StInt i)) =
+mangleIndexTree (StIndex pk base (StInt i)) =
StPrim IntAddOp [base, off]
where
off = StInt (i * size pk)
- size :: PrimKind -> Integer
+ size :: PrimRep -> Integer
size pk = case kindToSize pk of
{SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 8}
-mangleIndexTree (StIndex pk base off) =
+mangleIndexTree (StIndex pk base off) =
case pk of
- CharKind -> StPrim IntAddOp [base, off]
+ CharRep -> StPrim IntAddOp [base, off]
_ -> StPrim IntAddOp [base, off__2]
where
off__2 = StPrim SllOp [off, StInt (shift pk)]
- shift :: PrimKind -> Integer
- shift DoubleKind = 3
+ shift :: PrimRep -> Integer
+ shift DoubleRep = 3
shift _ = 2
cvtLitLit :: String -> String
cvtLitLit "stdin" = "__iob+0x0" -- This one is probably okay...
cvtLitLit "stdout" = "__iob+0x14" -- but these next two are dodgy at best
cvtLitLit "stderr" = "__iob+0x28"
-cvtLitLit s
+cvtLitLit s
| isHex s = s
| otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
- where
+ where
isHex ('0':'x':xs) = all isHexDigit xs
isHex _ = False
-- Now, where have I seen this before?
\begin{code}
-spRel
+spRel
:: Int -- desired stack offset in words, positive or negative
-> Addr
spRel n = AddrRegImm sp (ImmInt (n * 4))
\begin{code}
-getNewRegNCG :: PrimKind -> SUniqSM Reg
-getNewRegNCG pk =
- getSUnique `thenSUs` \ u ->
- returnSUs (mkReg u pk)
+getNewRegNCG :: PrimRep -> UniqSM Reg
+getNewRegNCG pk =
+ getUnique `thenUs` \ u ->
+ returnUs (mkReg u pk)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Stix where
-import AbsCSyn(MagicId)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import UniType(UniType)
-import Unique(Unique)
-data MagicId
-data CLabel
-data CodeSegment = DataSegment | TextSegment
-data PrimKind
-data PrimOp
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply
-data StixReg = StixMagicId MagicId | StixTemp Unique PrimKind
-data StixTree = StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString
-type StixTreeList = [StixTree] -> [StixTree]
-data Unique
-getUniqLabelNCG :: SplitUniqSupply -> CLabel
-sStLitLbl :: _PackedString -> StixTree
-stgBaseReg :: StixTree
-stgHp :: StixTree
-stgHpLim :: StixTree
-stgLivenessReg :: StixTree
-stgNode :: StixTree
-stgRetReg :: StixTree
-stgSpA :: StixTree
-stgSpB :: StixTree
-stgStdUpdRetVecReg :: StixTree
-stgStkOReg :: StixTree
-stgStkStubReg :: StixTree
-stgSuA :: StixTree
-stgSuB :: StixTree
-stgTagReg :: StixTree
-instance Eq CodeSegment
-
CodeSegment(..), StixReg(..), StixTree(..), StixTreeList(..),
sStLitLbl,
- stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg,
+ stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg,
stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg,
-- stgActivityReg,
stgStdUpdRetVecReg, stgStkStubReg,
- getUniqLabelNCG,
+ getUniqLabelNCG
-- And for self-sufficiency, by golly...
- MagicId, CLabel, PrimKind, PrimOp, Unique,
- SplitUniqSupply, SUniqSM(..)
) where
import AbsCSyn ( MagicId(..), kindFromMagicId, node, infoptr )
-import AbsPrel ( showPrimOp, PrimOp
+import PrelInfo ( showPrimOp, PrimOp
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import CLabelInfo ( CLabel, mkAsmTempLabel )
+import CLabel ( CLabel, mkAsmTempLabel )
import Outputable
-import PrimKind ( PrimKind(..) )
-import SplitUniq
-import Unique
-import Unpretty
+import UniqSupply
+import Unpretty
import Util
\end{code}
Here is the tag at the nodes of our @StixTree@. Notice its
-relationship with @PrimOp@ in prelude/PrimOps.
+relationship with @PrimOp@ in prelude/PrimOp.
\begin{code}
-- We can tag the leaves with constants/immediates.
| StInt Integer -- ** add Kind at some point
-#if __GLASGOW_HASKELL__ <= 22
- | StDouble Double
-#else
| StDouble Rational
-#endif
| StString FAST_STRING
| StLitLbl Unpretty -- literal labels (will be _-prefixed on some machines)
| StLitLit FAST_STRING -- innards from CLitLit
-- A typed offset from a base location
- | StIndex PrimKind StixTree StixTree -- kind, base, offset
+ | StIndex PrimRep StixTree StixTree -- kind, base, offset
-- An indirection from an address to its contents.
- | StInd PrimKind StixTree
+ | StInd PrimRep StixTree
-- Assignment is typed to determine size and register placement
- | StAssign PrimKind StixTree StixTree -- dst, src
+ | StAssign PrimRep StixTree StixTree -- dst, src
-- A simple assembly label that we might jump to.
-- Raw data (as in an info table).
- | StData PrimKind [StixTree]
+ | StData PrimRep [StixTree]
-- Primitive Operations
-- Calls to C functions
- | StCall FAST_STRING PrimKind [StixTree]
+ | StCall FAST_STRING PrimRep [StixTree]
-- Comments, of course
data StixReg = StixMagicId MagicId -- Regs which are part of the abstract machine model
- | StixTemp Unique PrimKind -- "Regs" which model local variables (CTemps) in
+ | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
-- the abstract C.
deriving ()
stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg)
stgStkStubReg = StReg (StixMagicId StkStubReg)
-getUniqLabelNCG :: SUniqSM CLabel
-getUniqLabelNCG =
- getSUnique `thenSUs` \ u ->
- returnSUs (mkAsmTempLabel u)
+getUniqLabelNCG :: UniqSM CLabel
+getUniqLabelNCG =
+ getUnique `thenUs` \ u ->
+ returnUs (mkAsmTempLabel u)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StixInfo where
-import AbsCSyn(AbstractC, CAddrMode)
-import HeapOffs(HeapOffset)
-import SplitUniq(SplitUniqSupply)
-import Stix(StixTree)
-genCodeInfoTable :: (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> AbstractC -> SplitUniqSupply -> [StixTree] -> [StixTree]
-
import Maybes ( maybeToBool, Maybe(..) )
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import Stix
-import SplitUniq
-import Unique
+import UniqSupply
import Unpretty
import Util
(HeapOffset -> Int) -- needed bit of Target
-> (CAddrMode -> StixTree) -- ditto
-> AbstractC
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr _) =
- returnSUs (\xs -> info : lbl : xs)
+ returnUs (\xs -> info : lbl : xs)
where
- info = StData PtrKind table
+ info = StData PtrRep table
lbl = StLabel info_lbl
table = case sm_rep of
StaticRep _ _ -> [
StInt (toInteger ptrs),
- StInt (toInteger size),
- upd_code,
+ StInt (toInteger size),
+ upd_code,
static___rtbl,
- tag]
+ tag]
SpecialisedRep ConstantRep _ _ _ -> [
StCLbl closure_lbl,
- upd_code,
- const___rtbl,
- tag]
+ upd_code,
+ const___rtbl,
+ tag]
SpecialisedRep CharLikeRep _ _ _ -> [
upd_code,
charlike___rtbl,
- tag]
+ tag]
SpecialisedRep IntLikeRep _ _ _ -> [
upd_code,
- intlike___rtbl,
+ intlike___rtbl,
tag]
SpecialisedRep _ _ _ updatable ->
SMNormalForm -> SLIT("Spec_N_")
SMSingleEntry -> SLIT("Spec_S_")
SMUpdatable -> SLIT("Spec_U_")
- ),
+ ),
uppInt size,
uppChar '_',
uppInt ptrs,
uppPStr SLIT("_rtbl")])
- in
+ in
case updatable of
SMNormalForm -> [upd_code, StLitLbl rtbl, tag]
- _ -> [StLitLbl rtbl, tag]
+ _ -> [StLitLbl rtbl, tag]
GenericRep _ _ updatable ->
- let rtbl = case updatable of
- SMNormalForm -> gen_N___rtbl
- SMSingleEntry -> gen_S___rtbl
+ let rtbl = case updatable of
+ SMNormalForm -> gen_N___rtbl
+ SMSingleEntry -> gen_S___rtbl
SMUpdatable -> gen_U___rtbl
- in [
+ in [
StInt (toInteger ptrs),
- StInt (toInteger size),
+ StInt (toInteger size),
upd_code,
- rtbl,
- tag]
+ rtbl,
+ tag]
BigTupleRep _ -> [
tuple___rtbl,
closure_lbl = closureLabelFromCI cl_info
sm_rep = closureSMRep cl_info
- maybe_selector = maybeSelectorInfo cl_info
- is_selector = maybeToBool maybe_selector
- (Just (_, select_word)) = maybe_selector
+ maybe_selector = maybeSelectorInfo cl_info
+ is_selector = maybeToBool maybe_selector
+ (Just (_, select_word)) = maybe_selector
tag = StInt (toInteger (closureSemiTag cl_info))
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StixInteger where
-import AbsCSyn(CAddrMode)
-import MachDesc(Target)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import SplitUniq(SplitUniqSupply)
-import Stix(StixTree)
-decodeFloatingKind :: PrimKind -> Target -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-encodeFloatingKind :: PrimKind -> Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpCompare :: Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpInt2Integer :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpInteger2Int :: Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpString2Integer :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpTake1Return1 :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpTake2Return1 :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-gmpTake2Return2 :: Target -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
-
\begin{code}
#include "HsVersions.h"
-module StixInteger (
- gmpTake1Return1, gmpTake2Return1, gmpTake2Return2,
- gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
- encodeFloatingKind, decodeFloatingKind
+module StixInteger (
+ gmpTake1Return1, gmpTake2Return1, gmpTake2Return2,
+ gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
+ encodeFloatingKind, decodeFloatingKind
) where
IMPORT_Trace -- ToDo: rm debugging
import AbsCSyn
import CgCompInfo ( mIN_MP_INT_SIZE )
import MachDesc
-import Pretty
-import AbsPrel ( PrimOp(..)
+import Pretty
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind(..) )
import Stix
-import SplitUniq
-import Unique
+import UniqSupply
import Util
\end{code}
\begin{code}
-gmpTake1Return1
- :: Target
+gmpTake1Return1
+ :: Target
-> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
-> FAST_STRING -- function name
-> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
-- argument (4 parts)
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
argument2 = mpStruct 2
result2 = mpStruct 2
result3 = mpStruct 3
result4 = mpStruct 4
-init2 = StCall SLIT("mpz_init") VoidKind [result2]
-init3 = StCall SLIT("mpz_init") VoidKind [result3]
-init4 = StCall SLIT("mpz_init") VoidKind [result4]
+init2 = StCall SLIT("mpz_init") VoidRep [result2]
+init3 = StCall SLIT("mpz_init") VoidRep [result3]
+init4 = StCall SLIT("mpz_init") VoidRep [result4]
-- hacking with Uncle Will:
#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
dr = a2stix cdr
liveness= a2stix clive
aa = a2stix caa
- sa = a2stix csa
- da = a2stix cda
+ sa = a2stix csa
+ da = a2stix cda
space = mpSpace data_hs 2 1 [sa]
- oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
+ oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
safeHp = saveLoc target Hp
- save = StAssign PtrKind safeHp oldHp
+ save = StAssign PtrRep safeHp oldHp
(a1,a2,a3) = toStruct data_hs argument1 (aa,sa,da)
- mpz_op = StCall rtn VoidKind [result2, argument1]
- restore = StAssign PtrKind stgHp safeHp
+ mpz_op = StCall rtn VoidRep [result2, argument1]
+ restore = StAssign PtrRep stgHp safeHp
(r1,r2,r3) = fromStruct data_hs result2 (ar,sr,dr)
in
- heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
+ heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
- returnSUs (heap_chk .
+ returnUs (heap_chk .
(\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
-gmpTake2Return1
- :: Target
+gmpTake2Return1
+ :: Target
-> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
-> FAST_STRING -- function name
-> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- liveness + 2 arguments (3 parts each)
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
let
da2 = a2stix cda2
space = mpSpace data_hs 3 1 [sa1, sa2]
- oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
+ oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
safeHp = saveLoc target Hp
- save = StAssign PtrKind safeHp oldHp
+ save = StAssign PtrRep safeHp oldHp
(a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
(a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
- mpz_op = StCall rtn VoidKind [result3, argument1, argument2]
- restore = StAssign PtrKind stgHp safeHp
+ mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
+ restore = StAssign PtrRep stgHp safeHp
(r1,r2,r3) = fromStruct data_hs result3 (ar,sr,dr)
in
- heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
+ heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
- returnSUs (heap_chk .
- (\xs -> a1 : a2 : a3 : a4 : a5 : a6
+ returnUs (heap_chk .
+ (\xs -> a1 : a2 : a3 : a4 : a5 : a6
: save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
gmpTake2Return2
- :: Target
+ :: Target
-> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- 2 results (3 parts each)
-> FAST_STRING -- function name
-> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- liveness + 2 arguments (3 parts each)
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2)
rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
a2stix = amodeToStix target
data_hs = dataHS target
- ar1 = a2stix car1
- sr1 = a2stix csr1
- dr1 = a2stix cdr1
- ar2 = a2stix car2
- sr2 = a2stix csr2
- dr2 = a2stix cdr2
+ ar1 = a2stix car1
+ sr1 = a2stix csr1
+ dr1 = a2stix cdr1
+ ar2 = a2stix car2
+ sr2 = a2stix csr2
+ dr2 = a2stix cdr2
liveness= a2stix clive
- aa1 = a2stix caa1
- sa1 = a2stix csa1
- da1 = a2stix cda1
- aa2 = a2stix caa2
+ aa1 = a2stix caa1
+ sa1 = a2stix csa1
+ da1 = a2stix cda1
+ aa2 = a2stix caa2
sa2 = a2stix csa2
da2 = a2stix cda2
space = StPrim IntMulOp [mpSpace data_hs 2 1 [sa1, sa2], StInt 2]
- oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
+ oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
safeHp = saveLoc target Hp
- save = StAssign PtrKind safeHp oldHp
+ save = StAssign PtrRep safeHp oldHp
(a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
(a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
- mpz_op = StCall rtn VoidKind [result3, result4, argument1, argument2]
- restore = StAssign PtrKind stgHp safeHp
+ mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
+ restore = StAssign PtrRep stgHp safeHp
(r1,r2,r3) = fromStruct data_hs result3 (ar1,sr1,dr1)
(r4,r5,r6) = fromStruct data_hs result4 (ar2,sr2,dr2)
in
- heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
+ heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
- returnSUs (heap_chk .
- (\xs -> a1 : a2 : a3 : a4 : a5 : a6
- : save : init3 : init4 : mpz_op
+ returnUs (heap_chk .
+ (\xs -> a1 : a2 : a3 : a4 : a5 : a6
+ : save : init3 : init4 : mpz_op
: r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
\end{code}
\begin{code}
-gmpCompare
- :: Target
+gmpCompare
+ :: Target
-> CAddrMode -- result (boolean)
-> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- alloc hp + 2 arguments (3 parts each)
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) =
let
data_hs = dataHS target
result = a2stix res
- hp = a2stix chp
+ hp = a2stix chp
aa1 = a2stix caa1
sa1 = a2stix csa1
da1 = a2stix cda1
da2 = a2stix cda2
argument1 = hp
- argument2 = StIndex IntKind hp (StInt (toInteger mpIntSize))
+ argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
(a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
(a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
- mpz_cmp = StCall SLIT("mpz_cmp") IntKind [argument1, argument2]
- r1 = StAssign IntKind result mpz_cmp
+ mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
+ r1 = StAssign IntRep result mpz_cmp
in
- returnSUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
+ returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
\end{code}
\begin{code}
-gmpInteger2Int
- :: Target
+gmpInteger2Int
+ :: Target
-> CAddrMode -- result
-> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) =
let
da = a2stix cda
(a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
- mpz_get_si = StCall SLIT("mpz_get_si") IntKind [hp]
- r1 = StAssign IntKind result mpz_get_si
+ mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
+ r1 = StAssign IntRep result mpz_get_si
in
- returnSUs (\xs -> a1 : a2 : a3 : r1 : xs)
+ returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
-gmpInt2Integer
- :: Target
+gmpInt2Integer
+ :: Target
-> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
-> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) =
- getUniqLabelNCG `thenSUs` \ zlbl ->
- getUniqLabelNCG `thenSUs` \ nlbl ->
- getUniqLabelNCG `thenSUs` \ jlbl ->
+ getUniqLabelNCG `thenUs` \ zlbl ->
+ getUniqLabelNCG `thenUs` \ nlbl ->
+ getUniqLabelNCG `thenUs` \ jlbl ->
let
a2stix = amodeToStix target
ar = a2stix car
sr = a2stix csr
dr = a2stix cdr
- hp = a2stix chp
+ hp = a2stix chp
i = a2stix n
- h1 = StAssign PtrKind (StInd PtrKind hp) arrayOfData_info
+ h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE
- h2 = StAssign IntKind (StInd IntKind (StIndex IntKind hp (StInt 1)))
- (StInt (toInteger size))
- cts = StInd IntKind (StIndex IntKind hp (dataHS target))
- test1 = StPrim IntEqOp [i, StInt 0]
- test2 = StPrim IntLtOp [i, StInt 0]
- cjmp1 = StCondJump zlbl test1
- cjmp2 = StCondJump nlbl test2
+ h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
+ (StInt (toInteger size))
+ cts = StInd IntRep (StIndex IntRep hp (dataHS target))
+ test1 = StPrim IntEqOp [i, StInt 0]
+ test2 = StPrim IntLtOp [i, StInt 0]
+ cjmp1 = StCondJump zlbl test1
+ cjmp2 = StCondJump nlbl test2
-- positive
- p1 = StAssign IntKind cts i
- p2 = StAssign IntKind sr (StInt 1)
- p3 = StJump (StCLbl jlbl)
+ p1 = StAssign IntRep cts i
+ p2 = StAssign IntRep sr (StInt 1)
+ p3 = StJump (StCLbl jlbl)
-- negative
- n0 = StLabel nlbl
- n1 = StAssign IntKind cts (StPrim IntNegOp [i])
- n2 = StAssign IntKind sr (StInt (-1))
- n3 = StJump (StCLbl jlbl)
+ n0 = StLabel nlbl
+ n1 = StAssign IntRep cts (StPrim IntNegOp [i])
+ n2 = StAssign IntRep sr (StInt (-1))
+ n3 = StJump (StCLbl jlbl)
-- zero
- z0 = StLabel zlbl
- z1 = StAssign IntKind sr (StInt 0)
- -- everybody
- a0 = StLabel jlbl
- a1 = StAssign IntKind ar (StInt 1)
- a2 = StAssign PtrKind dr hp
+ z0 = StLabel zlbl
+ z1 = StAssign IntRep sr (StInt 0)
+ -- everybody
+ a0 = StLabel jlbl
+ a1 = StAssign IntRep ar (StInt 1)
+ a2 = StAssign PtrRep dr hp
in
- returnSUs (\xs ->
+ returnUs (\xs ->
case n of
- CLit (MachInt c _) ->
+ CLit (MachInt c _) ->
if c == 0 then h1 : h2 : z1 : a1 : a2 : xs
- else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
- else h1 : h2 : n1 : n2 : a1 : a2 : xs
- _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
- : n0 : n1 : n2 : n3 : z0 : z1
+ else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
+ else h1 : h2 : n1 : n2 : a1 : a2 : xs
+ _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
+ : n0 : n1 : n2 : n3 : z0 : z1
: a0 : a1 : a2 : xs)
-gmpString2Integer
- :: Target
+gmpString2Integer
+ :: Target
-> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
-> (CAddrMode, CAddrMode) -- liveness, string
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) =
- getUniqLabelNCG `thenSUs` \ ulbl ->
+ getUniqLabelNCG `thenUs` \ ulbl ->
let
a2stix = amodeToStix target
data_hs = dataHS target
_ -> panic "String2Integer"
space = len `quot` 8 + 17 + mpIntSize +
varHeaderSize target (DataRep 0) + fixedHeaderSize target
- oldHp = StIndex PtrKind stgHp (StInt (toInteger (-space)))
+ oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
safeHp = saveLoc target Hp
- save = StAssign PtrKind safeHp oldHp
- result = StIndex IntKind stgHpLim (StInt (toInteger (-mpIntSize)))
- set_str = StCall SLIT("mpz_init_set_str") IntKind
+ save = StAssign PtrRep safeHp oldHp
+ result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
+ set_str = StCall SLIT("mpz_init_set_str") IntRep
[result, a2stix str, StInt 10]
test = StPrim IntEqOp [set_str, StInt 0]
cjmp = StCondJump ulbl test
- abort = StCall SLIT("abort") VoidKind []
+ abort = StCall SLIT("abort") VoidRep []
join = StLabel ulbl
- restore = StAssign PtrKind stgHp safeHp
+ restore = StAssign PtrRep stgHp safeHp
(a1,a2,a3) = fromStruct data_hs result (ar,sr,dr)
in
macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
- `thenSUs` \ heap_chk ->
+ `thenUs` \ heap_chk ->
- returnSUs (heap_chk .
+ returnUs (heap_chk .
(\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
-encodeFloatingKind
- :: PrimKind
- -> Target
+encodeFloatingKind
+ :: PrimRep
+ -> Target
-> CAddrMode -- result
-> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-- heap pointer for result, integer argument (3 parts), exponent
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) =
let
data_hs = dataHS target
result = a2stix res
- hp = a2stix chp
- aa = a2stix caa
- sa = a2stix csa
- da = a2stix cda
+ hp = a2stix chp
+ aa = a2stix caa
+ sa = a2stix csa
+ da = a2stix cda
expon = a2stix cexpon
- pk' = if size_of FloatKind == size_of DoubleKind
- then DoubleKind
- else pk
+ pk' = if size_of FloatRep == size_of DoubleRep
+ then DoubleRep
+ else pk
(a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
fn = case pk' of
- FloatKind -> SLIT("__encodeFloat")
- DoubleKind -> SLIT("__encodeDouble")
+ FloatRep -> SLIT("__encodeFloat")
+ DoubleRep -> SLIT("__encodeDouble")
_ -> panic "encodeFloatingKind"
encode = StCall fn pk' [hp, expon]
r1 = StAssign pk' result encode
in
- returnSUs (\xs -> a1 : a2 : a3 : r1 : xs)
+ returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
-decodeFloatingKind
- :: PrimKind
- -> Target
+decodeFloatingKind
+ :: PrimRep
+ -> Target
-> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
-- exponent result, integer result (3 parts)
-> (CAddrMode, CAddrMode)
-- heap pointer for exponent, floating argument
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) =
let
size_of = sizeof target
data_hs = dataHS target
- exponr = a2stix cexponr
- ar = a2stix car
- sr = a2stix csr
- dr = a2stix cdr
- hp = a2stix chp
- arg = a2stix carg
-
- pk' = if size_of FloatKind == size_of DoubleKind
- then DoubleKind
- else pk
- setup = StAssign PtrKind mpData_mantissa (StIndex IntKind hp (StInt 1))
+ exponr = a2stix cexponr
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+ hp = a2stix chp
+ arg = a2stix carg
+
+ pk' = if size_of FloatRep == size_of DoubleRep
+ then DoubleRep
+ else pk
+ setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
fn = case pk' of
- FloatKind -> SLIT("__decodeFloat")
- DoubleKind -> SLIT("__decodeDouble")
+ FloatRep -> SLIT("__decodeFloat")
+ DoubleRep -> SLIT("__decodeDouble")
_ -> panic "decodeFloatingKind"
- decode = StCall fn VoidKind [mantissa, hp, arg]
+ decode = StCall fn VoidRep [mantissa, hp, arg]
(a1,a2,a3) = fromStruct data_hs mantissa (ar,sr,dr)
- a4 = StAssign IntKind exponr (StInd IntKind hp)
+ a4 = StAssign IntRep exponr (StInd IntRep hp)
in
- returnSUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
+ returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
mpData_mantissa = mpData mantissa
mpIntSize = 3 :: Int
mpAlloc, mpSize, mpData :: StixTree -> StixTree
-mpAlloc base = StInd IntKind base
-mpSize base = StInd IntKind (StIndex IntKind base (StInt 1))
-mpData base = StInd PtrKind (StIndex IntKind base (StInt 2))
+mpAlloc base = StInd IntRep base
+mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
+mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
-mpSpace
+mpSpace
:: StixTree -- dataHs from Target
-> Int -- gmp structures needed
-> Int -- number of results
-> [StixTree] -- sizes to add for estimating result size
-> StixTree -- total space
-mpSpace data_hs gmp res sizes =
+mpSpace data_hs gmp res sizes =
foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
where
sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
\begin{code}
mpStruct :: Int -> StixTree
-mpStruct n = StIndex IntKind stgHpLim (StInt (toInteger (-(n * mpIntSize))))
+mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
-toStruct
+toStruct
:: StixTree -- dataHS, from Target
- -> StixTree
- -> (StixTree, StixTree, StixTree)
- -> (StixTree, StixTree, StixTree)
+ -> StixTree
+ -> (StixTree, StixTree, StixTree)
+ -> (StixTree, StixTree, StixTree)
toStruct data_hs str (alloc,size,arr) =
let
- f1 = StAssign IntKind (mpAlloc str) alloc
- f2 = StAssign IntKind (mpSize str) size
- f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr data_hs)
+ f1 = StAssign IntRep (mpAlloc str) alloc
+ f2 = StAssign IntRep (mpSize str) size
+ f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr data_hs)
in
(f1, f2, f3)
-fromStruct
+fromStruct
:: StixTree -- dataHS, from Target
- -> StixTree
- -> (StixTree, StixTree, StixTree)
- -> (StixTree, StixTree, StixTree)
+ -> StixTree
+ -> (StixTree, StixTree, StixTree)
+ -> (StixTree, StixTree, StixTree)
fromStruct data_hs str (alloc,size,arr) =
let
- e1 = StAssign IntKind alloc (mpAlloc str)
- e2 = StAssign IntKind size (mpSize str)
- e3 = StAssign PtrKind arr (StIndex PtrKind (mpData str)
+ e1 = StAssign IntRep alloc (mpAlloc str)
+ e2 = StAssign IntRep size (mpSize str)
+ e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
(StPrim IntNegOp [data_hs]))
in
(e1, e2, e3)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StixMacro where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-import Unique(Unique)
-data CAddrMode
-data CExprMacro
-data CStmtMacro
-data Target
-data SplitUniqSupply
-data StixTree
-doHeapCheck :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]
-genMacroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
-smStablePtrTable :: StixTree
-
module StixMacro (
genMacroCode, doHeapCheck, smStablePtrTable,
- Target, StixTree, SplitUniqSupply, CAddrMode, CExprMacro,
+ Target, StixTree, UniqSupply, CAddrMode, CExprMacro,
CStmtMacro
) where
import AbsCSyn
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import MachDesc {- lots -}
import CgCompInfo ( sTD_UF_SIZE, uF_RET, uF_SUA, uF_SUB, uF_UPDATEE )
import Stix
-import SplitUniq
-import Unique
+import UniqSupply
import Util
-
\end{code}
The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
-- hacking with Uncle Will:
#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
-genMacroCode
- :: Target
+genMacroCode
+ :: Target
-> CStmtMacro -- statement macro
-> [CAddrMode] -- args
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
genMacroCode target_STRICT macro args
= genmacro macro args
-- real thing: here we go -----------------------
- genmacro ARGS_CHK_A_LOAD_NODE args =
- getUniqLabelNCG `thenSUs` \ ulbl ->
+ genmacro ARGS_CHK_A_LOAD_NODE args =
+ getUniqLabelNCG `thenUs` \ ulbl ->
let [words, lbl] = map a2stix args
- temp = StIndex PtrKind stgSpA words
+ temp = StIndex PtrRep stgSpA words
test = StPrim AddrGeOp [stgSuA, temp]
cjmp = StCondJump ulbl test
- assign = StAssign PtrKind stgNode lbl
+ assign = StAssign PtrRep stgNode lbl
join = StLabel ulbl
in
- returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)
+ returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
- genmacro ARGS_CHK_A [words] =
- getUniqLabelNCG `thenSUs` \ ulbl ->
- let temp = StIndex PtrKind stgSpA (a2stix words)
+ genmacro ARGS_CHK_A [words] =
+ getUniqLabelNCG `thenUs` \ ulbl ->
+ let temp = StIndex PtrRep stgSpA (a2stix words)
test = StPrim AddrGeOp [stgSuA, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
in
- returnSUs (\xs -> cjmp : updatePAP : join : xs)
+ returnUs (\xs -> cjmp : updatePAP : join : xs)
\end{code}
\begin{code}
- genmacro ARGS_CHK_B_LOAD_NODE args =
- getUniqLabelNCG `thenSUs` \ ulbl ->
+ genmacro ARGS_CHK_B_LOAD_NODE args =
+ getUniqLabelNCG `thenUs` \ ulbl ->
let [words, lbl] = map a2stix args
- temp = StIndex PtrKind stgSuB (StPrim IntNegOp [words])
+ temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
test = StPrim AddrGeOp [stgSpB, temp]
cjmp = StCondJump ulbl test
- assign = StAssign PtrKind stgNode lbl
+ assign = StAssign PtrRep stgNode lbl
join = StLabel ulbl
in
- returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)
+ returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
- genmacro ARGS_CHK_B [words] =
- getUniqLabelNCG `thenSUs` \ ulbl ->
- let temp = StIndex PtrKind stgSuB (StPrim IntNegOp [a2stix words])
+ genmacro ARGS_CHK_B [words] =
+ getUniqLabelNCG `thenUs` \ ulbl ->
+ let temp = StIndex PtrRep stgSuB (StPrim IntNegOp [a2stix words])
test = StPrim AddrGeOp [stgSpB, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
in
- returnSUs (\xs -> cjmp : updatePAP : join : xs)
+ returnUs (\xs -> cjmp : updatePAP : join : xs)
\end{code}
genmacro HEAP_CHK args =
let [liveness,words,reenter] = map a2stix args
in
- doHeapCheck {-UNUSED NOW:target-} liveness words reenter
-
+ doHeapCheck liveness words reenter
\end{code}
The @STK_CHK@ macro checks for enough space on the stack between @SpA@
\begin{code}
- genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] =
+ genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] =
{- Need to check to see if we are compiling with stack checks
- getUniqLabelNCG `thenSUs` \ ulbl ->
- let words = StPrim IntNegOp
+ getUniqLabelNCG `thenUs` \ ulbl ->
+ let words = StPrim IntNegOp
[StPrim IntAddOp [a2stix aWords, a2stix bWords]]
- temp = StIndex PtrKind stgSpA words
+ temp = StIndex PtrRep stgSpA words
test = StPrim AddrGtOp [temp, stgSpB]
cjmp = StCondJump ulbl test
join = StLabel ulbl
in
- returnSUs (\xs -> cjmp : stackOverflow : join : xs)
+ returnUs (\xs -> cjmp : stackOverflow : join : xs)
-}
- returnSUs id
+ returnUs id
\end{code}
genmacro UPD_CAF args =
let [cafptr,bhptr] = map a2stix args
- w0 = StInd PtrKind cafptr
- w1 = StInd PtrKind (StIndex PtrKind cafptr (StInt 1))
- w2 = StInd PtrKind (StIndex PtrKind cafptr (StInt 2))
- a1 = StAssign PtrKind w0 caf_info
- a2 = StAssign PtrKind w1 smCAFlist
- a3 = StAssign PtrKind w2 bhptr
- a4 = StAssign PtrKind smCAFlist cafptr
+ w0 = StInd PtrRep cafptr
+ w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
+ w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
+ a1 = StAssign PtrRep w0 caf_info
+ a2 = StAssign PtrRep w1 smCAFlist
+ a3 = StAssign PtrRep w2 bhptr
+ a4 = StAssign PtrRep smCAFlist cafptr
in
- returnSUs (\xs -> a1 : a2 : a3 : a4 : xs)
+ returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
\end{code}
\begin{code}
- genmacro UPD_IND args =
- getUniqLabelNCG `thenSUs` \ ulbl ->
+ genmacro UPD_IND args =
+ getUniqLabelNCG `thenUs` \ ulbl ->
let [updptr, heapptr] = map a2stix args
test = StPrim AddrGtOp [updptr, smOldLim]
cjmp = StCondJump ulbl test
- updRoots = StAssign PtrKind smOldMutables updptr
+ updRoots = StAssign PtrRep smOldMutables updptr
join = StLabel ulbl
- upd0 = StAssign PtrKind (StInd PtrKind updptr) ind_info
- upd1 = StAssign PtrKind (StInd PtrKind
- (StIndex PtrKind updptr (StInt 1))) smOldMutables
- upd2 = StAssign PtrKind (StInd PtrKind
- (StIndex PtrKind updptr (StInt 2))) heapptr
+ upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info
+ upd1 = StAssign PtrRep (StInd PtrRep
+ (StIndex PtrRep updptr (StInt 1))) smOldMutables
+ upd2 = StAssign PtrRep (StInd PtrRep
+ (StIndex PtrRep updptr (StInt 2))) heapptr
in
- returnSUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
+ returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
\end{code}
\begin{code}
- genmacro UPD_INPLACE_NOPTRS args = returnSUs id
+ genmacro UPD_INPLACE_NOPTRS args = returnUs id
\end{code}
@UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
-the Appel-style garbage collector by default. This means some extra work
+the Appel-style garbage collector by default. This means some extra work
if we update an old generation object.
\begin{code}
genmacro UPD_INPLACE_PTRS [liveness] =
- getUniqLabelNCG `thenSUs` \ ulbl ->
+ getUniqLabelNCG `thenUs` \ ulbl ->
let cjmp = StCondJump ulbl testOldLim
- testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
+ testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
join = StLabel ulbl
- updUpd0 = StAssign PtrKind (StInd PtrKind stgNode) ind_info
- updUpd1 = StAssign PtrKind (StInd PtrKind
- (StIndex PtrKind stgNode (StInt 1))) smOldMutables
- updUpd2 = StAssign PtrKind (StInd PtrKind
- (StIndex PtrKind stgNode (StInt 2))) hpBack2
- hpBack2 = StIndex PtrKind stgHp (StInt (-2))
- updOldMutables = StAssign PtrKind smOldMutables stgNode
- updUpdReg = StAssign PtrKind stgNode hpBack2
+ updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info
+ updUpd1 = StAssign PtrRep (StInd PtrRep
+ (StIndex PtrRep stgNode (StInt 1))) smOldMutables
+ updUpd2 = StAssign PtrRep (StInd PtrRep
+ (StIndex PtrRep stgNode (StInt 2))) hpBack2
+ hpBack2 = StIndex PtrRep stgHp (StInt (-2))
+ updOldMutables = StAssign PtrRep smOldMutables stgNode
+ updUpdReg = StAssign PtrRep stgNode hpBack2
in
genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
- `thenSUs` \ heap_chk ->
- returnSUs (\xs -> (cjmp :
- heap_chk (updUpd0 : updUpd1 : updUpd2 :
+ `thenUs` \ heap_chk ->
+ returnUs (\xs -> (cjmp :
+ heap_chk (updUpd0 : updUpd1 : updUpd2 :
updOldMutables : updUpdReg : join : xs)))
\end{code}
\begin{code}
- genmacro UPD_BH_UPDATABLE args = returnSUs id
+ genmacro UPD_BH_UPDATABLE args = returnUs id
genmacro UPD_BH_SINGLE_ENTRY [arg] =
let
- update = StAssign PtrKind (StInd PtrKind (a2stix arg)) bh_info
+ update = StAssign PtrRep (StInd PtrRep (a2stix arg)) bh_info
in
- returnSUs (\xs -> update : xs)
+ returnUs (\xs -> update : xs)
\end{code}
genmacro PUSH_STD_UPD_FRAME args =
let [bhptr, aWords, bWords] = map a2stix args
- frame n = StInd PtrKind
- (StIndex PtrKind stgSpB (StPrim IntAddOp
+ frame n = StInd PtrRep
+ (StIndex PtrRep stgSpB (StPrim IntAddOp
[bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
- a1 = StAssign PtrKind (frame uF_RET) stgRetReg
- a2 = StAssign PtrKind (frame uF_SUB) stgSuB
- a3 = StAssign PtrKind (frame uF_SUA) stgSuA
- a4 = StAssign PtrKind (frame uF_UPDATEE) bhptr
+ a1 = StAssign PtrRep (frame uF_RET) stgRetReg
+ a2 = StAssign PtrRep (frame uF_SUB) stgSuB
+ a3 = StAssign PtrRep (frame uF_SUA) stgSuA
+ a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
- updSuB = StAssign PtrKind
- stgSuB (StIndex PtrKind stgSpB (StPrim IntAddOp
+ updSuB = StAssign PtrRep
+ stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
[bWords, StInt (toInteger sTD_UF_SIZE)]))
- updSuA = StAssign PtrKind
- stgSuA (StIndex PtrKind stgSpA (StPrim IntNegOp [aWords]))
+ updSuA = StAssign PtrRep
+ stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
in
- returnSUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
+ returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
\end{code}
\begin{code}
genmacro POP_STD_UPD_FRAME args =
- let frame n = StInd PtrKind (StIndex PtrKind stgSpB (StInt (toInteger (-n))))
+ let frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
- grabRet = StAssign PtrKind stgRetReg (frame uF_RET)
- grabSuB = StAssign PtrKind stgSuB (frame uF_SUB)
- grabSuA = StAssign PtrKind stgSuA (frame uF_SUA)
+ grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
+ grabSuB = StAssign PtrRep stgSuB (frame uF_SUB)
+ grabSuA = StAssign PtrRep stgSuA (frame uF_SUA)
- updSpB = StAssign PtrKind
- stgSpB (StIndex PtrKind stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
+ updSpB = StAssign PtrRep
+ stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
in
- returnSUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
+ returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
\end{code}
-@PUSH_CON_UPD_FRAME@ appears to be unused at the moment.
-
+The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal''
+compilation.
\begin{code}
-{- UNUSED:
- genmacro PUSH_CON_UPD_FRAME args =
- panic "genMacroCode:PUSH_CON_UPD_FRAME"
--}
-\end{code}
-
-The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' compilation.
-
-\begin{code}
-
- genmacro SET_ARITY args = returnSUs id
- genmacro CHK_ARITY args = returnSUs id
-
+ genmacro SET_ARITY args = returnUs id
+ genmacro CHK_ARITY args = returnUs id
\end{code}
This one only applies if we have a machine register devoted to TagReg.
-
\begin{code}
-
- genmacro SET_TAG [tag] =
- let set_tag = StAssign IntKind stgTagReg (a2stix tag)
+ genmacro SET_TAG [tag] =
+ let set_tag = StAssign IntRep stgTagReg (a2stix tag)
in
- case stg_reg TagReg of
- Always _ -> returnSUs id
- Save _ -> returnSUs (\xs -> set_tag : xs)
-
+ case stg_reg TagReg of
+ Always _ -> returnUs id
+ Save _ -> returnUs (\ xs -> set_tag : xs)
\end{code}
Do the business for a @HEAP_CHK@, having converted the args to Trees
\begin{code}
-doHeapCheck
- :: {- unused now: Target
+doHeapCheck
+ :: {- unused now: Target
-> -}StixTree -- liveness
-> StixTree -- words needed
-> StixTree -- always reenter node? (boolean)
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
doHeapCheck {-target:unused now-} liveness words reenter =
- getUniqLabelNCG `thenSUs` \ ulbl ->
- let newHp = StIndex PtrKind stgHp words
- assign = StAssign PtrKind stgHp newHp
+ getUniqLabelNCG `thenUs` \ ulbl ->
+ let newHp = StIndex PtrRep stgHp words
+ assign = StAssign PtrRep stgHp newHp
test = StPrim AddrLeOp [stgHp, stgHpLim]
cjmp = StCondJump ulbl test
- arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
+ arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
-- ToDo: Overflow? (JSM)
- gc = StCall SLIT("PerformGC_wrapper") VoidKind [arg]
+ gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
join = StLabel ulbl
in
- returnSUs (\xs -> assign : cjmp : gc : join : xs)
+ returnUs (\xs -> assign : cjmp : gc : join : xs)
\end{code}
updatePAP, stackOverflow :: StixTree
updatePAP = StJump (sStLitLbl SLIT("UpdatePAP"))
-stackOverflow = StCall SLIT("StackOverflow") VoidKind []
+stackOverflow = StCall SLIT("StackOverflow") VoidRep []
\end{code}
-Storage manager nonsense. Note that the indices are dependent on
+Storage manager nonsense. Note that the indices are dependent on
the definition of the smInfo structure in SMinterface.lh
\begin{code}
storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree
storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
-smCAFlist = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_CAFLIST))
-smOldMutables = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDMUTABLES))
-smOldLim = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDLIM))
+smCAFlist = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_CAFLIST))
+smOldMutables = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDMUTABLES))
+smOldLim = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDLIM))
-smStablePtrTable = StInd PtrKind
- (StIndex PtrKind storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
+smStablePtrTable = StInd PtrRep
+ (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StixPrim where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import CharSeq(CSeq)
-import CostCentre(CostCentre)
-import HeapOffs(HeapOffset)
-import MachDesc(RegLoc, Target)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SMRep(SMRep)
-import SplitUniq(SplitUniqSupply)
-import Stix(CodeSegment, StixReg, StixTree)
-import UniType(UniType)
-import Unique(Unique)
-data CAddrMode
-data Target
-data PrimOp
-data SplitUniqSupply
-data StixTree
-amodeCode :: Target -> CAddrMode -> StixTree
-amodeCode' :: Target -> CAddrMode -> StixTree
-genPrimCode :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
-
module StixPrim (
genPrimCode, amodeCode, amodeCode',
- Target, CAddrMode, StixTree, PrimOp, SplitUniqSupply
+ Target, CAddrMode, StixTree, PrimOp, UniqSupply
) where
IMPORT_Trace -- ToDo: rm debugging
import AbsCSyn
-import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), TyCon,
+import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), TyCon,
getPrimOpResultInfo, isCompareOp, showPrimOp
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( cmpTyCon ) -- pragmas only
import CgCompInfo ( spARelToInt, spBRelToInt )
import MachDesc
-import Pretty
-import PrimKind ( isFloatingKind )
+import Pretty
+import PrimRep ( isFloatingRep )
import CostCentre
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import Stix
import StixMacro ( smStablePtrTable )
import StixInteger {- everything -}
-import SplitUniq
-import Unique
+import UniqSupply
import Unpretty
import Util
imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
genPrimCode
- :: Target
+ :: Target
-> [CAddrMode] -- results
-> PrimOp -- op
-> [CAddrMode] -- args
- -> SUniqSM StixTreeList
+ -> UniqSM StixTreeList
\end{code}
heap_chkr = heapCheck target
size_of = sizeof target
fixed_hs = fixedHeaderSize target
- var_hs = varHeaderSize target
+ var_hs = varHeaderSize target
--- real code will follow... -------------
\end{code}
-The (MP) integer operations are a true nightmare. Since we don't have a
+The (MP) integer operations are a true nightmare. Since we don't have a
convenient abstract way of allocating temporary variables on the (C) stack,
we use the space just below HpLim for the @MP_INT@ structures, and modify our
heap check accordingly.
\begin{code}
genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] =
- decodeFloatingKind FloatKind target (exponr,ar,sr,dr) (hp, arg)
+ decodeFloatingKind FloatRep target (exponr,ar,sr,dr) (hp, arg)
genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] =
- decodeFloatingKind DoubleKind target (exponr,ar,sr,dr) (hp, arg)
+ decodeFloatingKind DoubleRep target (exponr,ar,sr,dr) (hp, arg)
genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
= gmpInt2Integer target (ar,sr,dr) (hp, n)
= gmpInteger2Int target res (hp, aa,sa,da)
genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] =
- encodeFloatingKind FloatKind target res (hp, aa,sa,da, expon)
+ encodeFloatingKind FloatRep target res (hp, aa,sa,da, expon)
genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] =
- encodeFloatingKind DoubleKind target res (hp, aa,sa,da, expon)
+ encodeFloatingKind DoubleRep target res (hp, aa,sa,da, expon)
genprim [res] Int2AddrOp [arg] =
- simpleCoercion AddrKind res arg
+ simpleCoercion AddrRep res arg
genprim [res] Addr2IntOp [arg] =
- simpleCoercion IntKind res arg
+ simpleCoercion IntRep res arg
genprim [res] Int2WordOp [arg] =
- simpleCoercion IntKind{-WordKind?-} res arg
+ simpleCoercion IntRep{-WordRep?-} res arg
genprim [res] Word2IntOp [arg] =
- simpleCoercion IntKind res arg
+ simpleCoercion IntRep res arg
\end{code}
\begin{code}
- genprim [] ErrorIOPrimOp [rhs] =
- let changeTop = StAssign PtrKind topClosure (a2stix rhs)
+ genprim [] ErrorIOPrimOp [rhs] =
+ let changeTop = StAssign PtrRep topClosure (a2stix rhs)
in
- returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
+ returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
\end{code}
\begin{code}
genprim [res] NewArrayOp args =
let [liveness, n, initial] = map a2stix args
- result = a2stix res
+ result = a2stix res
space = StPrim IntAddOp [n, mut_hs]
- loc = StIndex PtrKind stgHp
+ loc = StIndex PtrRep stgHp
(StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
- assign = StAssign PtrKind result loc
- initialise = StCall SLIT("newArrZh_init") VoidKind [result, n, initial]
+ assign = StAssign PtrRep result loc
+ initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
in
- heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk ->
+ heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk ->
- returnSUs (heap_chk . (\xs -> assign : initialise : xs))
+ returnUs (heap_chk . (\xs -> assign : initialise : xs))
genprim [res] (NewByteArrayOp pk) args =
let [liveness, count] = map a2stix args
- result = a2stix res
+ result = a2stix res
n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))]
- slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntKind - 1))]
- words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntKind))]
+ slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntRep - 1))]
+ words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntRep))]
space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]]
- loc = StIndex PtrKind stgHp
+ loc = StIndex PtrRep stgHp
(StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
- assign = StAssign PtrKind result loc
- init1 = StAssign PtrKind (StInd PtrKind loc) arrayOfData_info
- init2 = StAssign IntKind
- (StInd IntKind
- (StIndex IntKind loc
+ assign = StAssign PtrRep result loc
+ init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
+ init2 = StAssign IntRep
+ (StInd IntRep
+ (StIndex IntRep loc
(StInt (toInteger fixed_hs))))
- (StPrim IntAddOp [words,
+ (StPrim IntAddOp [words,
StInt (toInteger (var_hs (DataRep 0)))])
in
- heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk ->
+ heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk ->
- returnSUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
+ returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
genprim [res] SameMutableArrayOp args =
let compare = StPrim AddrEqOp (map a2stix args)
- assign = StAssign IntKind (a2stix res) compare
+ assign = StAssign IntRep (a2stix res) compare
in
- returnSUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
genprim res@[_] SameMutableByteArrayOp args =
genprim res SameMutableArrayOp args
genprim [lhs] UnsafeFreezeArrayOp [rhs] =
let lhs' = a2stix lhs
rhs' = a2stix rhs
- header = StInd PtrKind lhs'
- assign = StAssign PtrKind lhs' rhs'
- freeze = StAssign PtrKind header imMutArrayOfPtrs_info
+ header = StInd PtrRep lhs'
+ assign = StAssign PtrRep lhs' rhs'
+ freeze = StAssign PtrRep header imMutArrayOfPtrs_info
in
- returnSUs (\xs -> assign : freeze : xs)
+ returnUs (\xs -> assign : freeze : xs)
genprim [lhs] UnsafeFreezeByteArrayOp [rhs] =
- simpleCoercion PtrKind lhs rhs
+ simpleCoercion PtrRep lhs rhs
\end{code}
let lhs' = a2stix lhs
obj' = a2stix obj
ix' = a2stix ix
- base = StIndex IntKind obj' mut_hs
- assign = StAssign PtrKind lhs' (StInd PtrKind (StIndex PtrKind base ix'))
+ base = StIndex IntRep obj' mut_hs
+ assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
in
- returnSUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
genprim [lhs] WriteArrayOp [obj, ix, v] =
let obj' = a2stix obj
ix' = a2stix ix
v' = a2stix v
- base = StIndex IntKind obj' mut_hs
- assign = StAssign PtrKind (StInd PtrKind (StIndex PtrKind base ix')) v'
+ base = StIndex IntRep obj' mut_hs
+ assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
in
- returnSUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
genprim lhs@[_] (IndexByteArrayOp pk) args =
genprim lhs (ReadByteArrayOp pk) args
let lhs' = a2stix lhs
obj' = a2stix obj
ix' = a2stix ix
- base = StIndex IntKind obj' data_hs
+ base = StIndex IntRep obj' data_hs
assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
in
- returnSUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
genprim [lhs] (IndexOffAddrOp pk) [obj, ix] =
let lhs' = a2stix lhs
ix' = a2stix ix
assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
in
- returnSUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
genprim [] (WriteByteArrayOp pk) [obj, ix, v] =
let obj' = a2stix obj
ix' = a2stix ix
v' = a2stix v
- base = StIndex IntKind obj' data_hs
+ base = StIndex IntRep obj' data_hs
assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
in
- returnSUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
\end{code}
Stable pointer operations.
genprim [lhs] DeRefStablePtrOp [sp] =
let lhs' = a2stix lhs
- pk = getAmodeKind lhs
+ pk = getAmodeRep lhs
sp' = a2stix sp
call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
assign = StAssign pk lhs' call
in
- returnSUs (\xs -> assign : xs)
+ returnUs (\xs -> assign : xs)
\end{code}
EXTDATA(MK_INFO_LBL(StablePointerTable)); \
EXTDATA(UnusedSP); \
StgStablePtr newSP; \
- \
+ \
if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
- \
+ \
/* any strictly increasing expression will do here */ \
I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
- \
+ \
I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
P_ SPTable; \
- \
+ \
HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
- \
+ \
SPTable = Hp + 1 - (_FHS + NewSize); \
SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
StorageMgrInfo.StablePointerTable = SPTable; \
} \
- \
+ \
newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
stablePtr = newSP; \
\begin{pseudocode}
genprim [lhs] MakeStablePtrOp args =
- let
+ let
-- some useful abbreviations (I'm sure these must exist already)
- add = trPrim . IntAddOp
+ add = trPrim . IntAddOp
sub = trPrim . IntSubOp
one = trInt [1]
- dec x = trAssign IntKind [x, sub [x, one]]
- inc x = trAssign IntKind [x, add [x, one]]
+ dec x = trAssign IntRep [x, sub [x, one]]
+ inc x = trAssign IntRep [x, add [x, one]]
-- tedious hardwiring in of closure layout offsets (from SMClosures)
dynHS = 2 + fixedHeaderSize md sty + varHeaderSize md sty DynamicRep
- spt_SIZE c = trIndex PtrKind [c, trInt [fhs + gc_reserved] ]
- spt_NoPTRS c = trIndex PtrKind [c, trInt [fhs + gc_reserved + 1] ]
- spt_SPTR c i = trIndex PtrKind [c, add [trInt [dynHS], i]]
- spt_TOP c = trIndex PtrKind [c, add [trInt [dynHS], spt_NoPTRS c]]
- spt_FREE c i = trIndex PtrKind [c, add [trInt [dynHS], spt_NoPTRS c]]
+ spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
+ spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
+ spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
+ spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
+ spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
-- tedious hardwiring in of stack manipulation macros (from SMClosures)
spt_FULL c lbl =
trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
spt_EMPTY c lbl =
trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
- spt_PUSH c f = [
- trAssign PtrKind [spt_FREE c (spt_TOP c), f],
+ spt_PUSH c f = [
+ trAssign PtrRep [spt_FREE c (spt_TOP c), f],
inc (spt_TOP c),
- spt_POP c x = [
- dec (spt_TOP c),
- trAssign PtrKind [x, spt_FREE c (spt_TOP c)]
+ spt_POP c x = [
+ dec (spt_TOP c),
+ trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
]
-- now to get down to business
newSP = -- another temporary
allocNewTable = -- some sort fo heap allocation needed
- copyOldTable = trCall "enlargeSPTable" PtrKind [newSPT, spt]
+ copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
- enlarge =
+ enlarge =
allocNewTable ++ [
copyOldTable,
- trAssign PtrKind [spt, newSPT]
+ trAssign PtrRep [spt, newSPT]
allocate = [
spt_POP spt newSP,
- trAssign PtrKind [spt_SPTR spt newSP, unstable],
- trAssign StablePtrKind [lhs', newSP]
+ trAssign PtrRep [spt_SPTR spt newSP, unstable],
+ trAssign StablePtrRep [lhs', newSP]
]
-
+
in
getUniqLabelCTS `thenCTS` \ oklbl ->
- returnCodes sty md
+ returnCodes sty md
(spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
\end{pseudocode}
\begin{code}
genprim res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp"
- genprim lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
+ genprim lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
| is_asm = error "ERROR: Native code generator can't handle casm"
| otherwise =
case lhs of
- [] -> returnSUs (\xs -> (StCall fn VoidKind args) : xs)
+ [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
[lhs] ->
let lhs' = a2stix lhs
- pk = if isFloatingKind (getAmodeKind lhs) then DoubleKind else IntKind
+ pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
call = StAssign pk lhs' (StCall fn pk args)
in
- returnSUs (\xs -> call : xs)
+ returnUs (\xs -> call : xs)
where
args = map amodeCodeForCCall rhs
- amodeCodeForCCall x =
+ amodeCodeForCCall x =
let base = a2stix' x
in
- case getAmodeKind x of
- ArrayKind -> StIndex PtrKind base mut_hs
- ByteArrayKind -> StIndex IntKind base data_hs
- MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
+ case getAmodeRep x of
+ ArrayRep -> StIndex PtrRep base mut_hs
+ ByteArrayRep -> StIndex IntRep base data_hs
+ MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
_ -> base
-\end{code}
+\end{code}
Now the more mundane operations.
\begin{code}
- genprim lhs op rhs =
+ genprim lhs op rhs =
let lhs' = map a2stix lhs
rhs' = map a2stix' rhs
in
- returnSUs (\ xs -> simplePrim lhs' op rhs' : xs)
+ returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
{-
- simpleCoercion
- :: Target
- -> PrimKind
- -> [CAddrMode]
- -> [CAddrMode]
- -> SUniqSM StixTreeList
+ simpleCoercion
+ :: Target
+ -> PrimRep
+ -> [CAddrMode]
+ -> [CAddrMode]
+ -> UniqSM StixTreeList
-}
simpleCoercion pk lhs rhs =
- returnSUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs)
+ returnUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs)
\end{code}
Here we try to rewrite primitives into a form the code generator
-can understand. Any primitives not handled here must be handled
+can understand. Any primitives not handled here must be handled
at the level of the specific code generator.
\begin{code}
{-
- simplePrim
- :: Target
- -> [StixTree]
- -> PrimOp
- -> [StixTree]
+ simplePrim
+ :: Target
+ -> [StixTree]
+ -> PrimOp
+ -> [StixTree]
-> StixTree
-}
\end{code}
\begin{code}
simplePrim [lhs] op rest = StAssign pk lhs (StPrim op rest)
- where pk = if isCompareOp op then IntKind
- else case getPrimOpResultInfo op of
+ where pk = if isCompareOp op then IntRep
+ else case getPrimOpResultInfo op of
ReturnsPrim pk -> pk
_ -> simplePrim_error op
\begin{code}
-amodeCode, amodeCode'
- :: Target
- -> CAddrMode
+amodeCode, amodeCode'
+ :: Target
+ -> CAddrMode
-> StixTree
-amodeCode'{-'-} target_STRICT am@(CVal rr CharKind)
+amodeCode'{-'-} target_STRICT am@(CVal rr CharRep)
| mixedTypeLocn am = StPrim ChrOp [amodeToStix target am]
| otherwise = amodeToStix target am
a2stix = amodeToStix target
-- real code: ----------------------------------
- acode am@(CVal rr CharKind) | mixedTypeLocn am =
- StInd IntKind (acode (CAddr rr))
+ acode am@(CVal rr CharRep) | mixedTypeLocn am =
+ StInd IntRep (acode (CAddr rr))
acode (CVal rr pk) = StInd pk (acode (CAddr rr))
- acode (CAddr r@(SpARel spA off)) =
- StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r)))
+ acode (CAddr (SpARel spA off)) =
+ StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
- acode (CAddr r@(SpBRel spB off)) =
- StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r)))
+ acode (CAddr (SpBRel spB off)) =
+ StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
acode (CAddr (HpRel hp off)) =
- StIndex IntKind stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off)))))
+ StIndex IntRep stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off)))))
acode (CAddr (NodeRel off)) =
- StIndex IntKind stgNode (StInt (toInteger (hp_rel off)))
+ StIndex IntRep stgNode (StInt (toInteger (hp_rel off)))
acode (CReg magic) = StReg (StixMagicId magic)
acode (CTemp uniq pk) = StReg (StixTemp uniq pk)
acode (CUnVecLbl dir _) = StCLbl dir
- acode (CTableEntry base off pk) =
+ acode (CTableEntry base off pk) =
StInd pk (StIndex pk (acode base) (acode off))
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
- acode (CCharLike (CLit (MachChar c))) =
+ acode (CCharLike (CLit (MachChar c))) =
StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
where off = char_like * ord c
- acode (CCharLike x) =
+ acode (CCharLike x) =
StPrim IntAddOp [charLike, off]
- where off = StPrim IntMulOp [acode x,
+ where off = StPrim IntMulOp [acode x,
StInt (toInteger (char_like))]
- acode (CIntLike (CLit (MachInt i _))) =
+ acode (CIntLike (CLit (MachInt i _))) =
StPrim IntAddOp [intLikePtr, StInt off]
where off = toInteger int_like * i
- acode (CIntLike x) =
+ acode (CIntLike x) =
StPrim IntAddOp [intLikePtr, off]
where off = StPrim IntMulOp [acode x,
StInt (toInteger int_like)]
-- COffsets are in words, not bytes!
acode (COffset off) = StInt (toInteger (hp_rel off))
- acode (CMacroExpr _ macro [arg]) =
+ acode (CMacroExpr _ macro [arg]) =
case macro of
- INFO_PTR -> StInd PtrKind (a2stix arg)
+ INFO_PTR -> StInd PtrRep (a2stix arg)
ENTRY_CODE -> a2stix arg
INFO_TAG -> tag
EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
where
- tag = StInd IntKind (StIndex IntKind (a2stix arg) (StInt (-2)))
+ tag = StInd IntRep (StIndex IntRep (a2stix arg) (StInt (-2)))
-- That ``-2'' really bothers me. (JSM)
acode (CCostCentre cc print_as_string)
intLikePtr :: StixTree
-intLikePtr = StInd PtrKind (sStLitLbl SLIT("INTLIKE_closures"))
+intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
-- The CHARLIKE base
topClosure, flushStdout, flushStderr, errorIO :: StixTree
-topClosure = StInd PtrKind (sStLitLbl SLIT("TopClosure"))
-flushStdout = StCall SLIT("fflush") VoidKind [StLitLit SLIT("stdout")]
-flushStderr = StCall SLIT("fflush") VoidKind [StLitLit SLIT("stderr")]
-errorIO = StJump (StInd PtrKind (sStLitLbl SLIT("ErrorIO_innards")))
+topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
+flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
+flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
+errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
\end{code}
--- /dev/null
+Return-Path: mattson@dcs.gla.ac.uk
+Return-Path: <mattson@dcs.gla.ac.uk>
+Received: from starbuck.dcs.gla.ac.uk by goggins.dcs.gla.ac.uk
+ with LOCAL SMTP (PP) id <02535-0@goggins.dcs.gla.ac.uk>;
+ Thu, 18 Nov 1993 09:59:57 +0000
+To: Robert.Corbett@Eng.Sun.COM
+cc: partain@dcs.gla.ac.uk
+Subject: Re: [Robert.Corbett@Eng.Sun.COM: Re: possible bug, byacc 1.9]
+In-reply-to: Your message from 9:46 AM GMT
+Date: Thu, 18 Nov 93 09:59:53 +0000
+From: Jim Mattson <mattson@dcs.gla.ac.uk>
+
+It's clear that this feature improves error detection, but it's not
+clear to me how it improves the scope of possible error recoveries.
+
+If I understand your explanation, it sounds like the only alternative
+(short of changing the byacc source) is to add tens or hundreds of
+error productions sprinkled throughout the code anywhere that an
+unexpected symbol may appear, since no intervening reductions are
+allowed.
+
+Although the addition of all of these error productions increases the
+scope of possible error recoveries, the same functionality (with, in fact,
+the same approach) is provided by other versions of yacc. The apparent
+advantage of other versions of yacc is that they provide a facility by
+which a single _default_ error production can handle a number of
+possibilities (after some possibly illegal reductions have been performed).
+
+Am I missing something?
+
+--jim
+--------
+In reply to the following message:
+--------
+
+------- Forwarded Message
+
+Date: Wed, 17 Nov 93 22:33:44 PST
+From: Robert.Corbett@Eng.Sun.COM (Robert Corbett)
+Message-Id: <9311180633.AA07545@lupa.Eng.Sun.COM>
+To: partain@dcs.gla.ac.uk
+Subject: Re: possible bug, byacc 1.9
+
+It is a feature. One difference between Berkeley Yacc and its
+predecessors is that the parsers Berkeley Yacc produces detect
+errors as soon as possible. That will lead to different behavior.
+
+In this particular case, the token "IN" is not a permitted
+lookahead symbol in state 390. AT&T Yacc parsers will not detect
+the error until after doing more reductions than Berkeley Yacc
+parsers. Doing reductions in illegal contexts limits the scope of
+recoveries that are possible (unless backtracking is possible).
+
+I am sorry that my attempt to provide better error detection is
+causing you trouble. You can get the AT&T Yacc behavior by
+replacing the routine sole_reduction in mkpar.c with a routine
+that returns the most frequently occurring reduction.
+
+ Yours truly,
+ Bob Corbett
+
+- ----- Begin Included Message -----
+
+>From partain@dcs.gla.ac.uk Wed Nov 17 05:03:44 1993
+To: robert.corbett@Eng
+Subject: possible bug, byacc 1.9
+Date: Wed, 17 Nov 93 12:33:42 +0000
+From: Will Partain <partain@dcs.gla.ac.uk>
+
+Sadly, it's in a *HUGE* grammar, which I will send you if you have the
+stomach for it.
+
+The problem occurs where {Sun's /usr/lang/yacc, bison} say:
+
+ state 390
+
+ aexp -> var . (rule 356)
+ aexp -> var . AT aexp (rule 366)
+
+ AT shift, and go to state 508
+ $default reduce using rule 356 (aexp)
+
+but byacc says
+
+ state 396
+ aexp : var . (356)
+ aexp : var . AT aexp (366)
+
+ AT shift 511
+ error reduce 356
+ VARID reduce 356
+ CONID reduce 356
+ VARSYM reduce 356
+ CONSYM reduce 356
+ MINUS reduce 356
+ INTEGER reduce 356
+ FLOAT reduce 356
+ CHAR reduce 356
+ STRING reduce 356
+ CHARPRIM reduce 356
+ INTPRIM reduce 356
+ FLOATPRIM reduce 356
+ DOUBLEPRIM reduce 356
+ CLITLIT reduce 356
+ VOIDPRIM reduce 356
+ CCURLY reduce 356
+ VCCURLY reduce 356
+ SEMI reduce 356
+ OBRACK reduce 356
+ CBRACK reduce 356
+ OPAREN reduce 356
+ CPAREN reduce 356
+ COMMA reduce 356
+ BQUOTE reduce 356
+ RARROW reduce 356
+ VBAR reduce 356
+ EQUAL reduce 356
+ DOTDOT reduce 356
+ DCOLON reduce 356
+ LARROW reduce 356
+ WILDCARD reduce 356
+ LAZY reduce 356
+ WHERE reduce 356
+ OF reduce 356
+ THEN reduce 356
+ ELSE reduce 356
+ PLUS reduce 356
+
+The token that comes in is "IN"; bison/sun-yacc-generated parser
+tickles the default, reduces to "aexp", but byacc-generated tickles
+"error" and the rest is history.
+
+Maybe this is enough for you to exclaim, "Oh yes, that's a feature."
+
+As I say, more info if you want it.
+
+Will Partain
+
+
+- ----- End Included Message -----
+
+
+
+------- End of Forwarded Message
+
+--------
--- /dev/null
+If you want to debug...
+
+* the lexer:
+
+ run "flex" with the -d flag; compile as normal thereafter
+
+* the parser:
+
+ compile hsparser.tab.c and main.c with EXTRA_CC_OPTS=-DHSP_DEBUG
+
+ run hsp with -D; it's dumping the output into *stdout*,
+ so you have to do something weird to look at it.
--- /dev/null
+Stuff the Ugenny things show to the parser.
+
+\begin{code}
+module UgenAll (
+ -- re-exported Prelude stuff
+ returnUgn, thenUgn,
+
+ -- stuff defined in utils module
+ UgenUtil.. ,
+
+ -- re-exported ugen-generated stuff
+ U_binding.. ,
+ U_constr.. ,
+ U_coresyn.. ,
+ U_entidt.. ,
+ U_finfot.. ,
+ U_hpragma.. ,
+ U_list.. ,
+ U_literal.. ,
+ U_maybe.. ,
+ U_either.. ,
+ U_pbinding.. ,
+ U_qid.. ,
+ U_tree.. ,
+ U_ttype..
+
+ ) where
+
+import PreludeGlaST
+
+import Ubiq{-uitous-}
+
+-- friends:
+import U_binding
+import U_constr
+import U_coresyn
+import U_entidt
+import U_finfot
+import U_hpragma
+import U_list
+import U_literal
+import U_maybe
+import U_either
+import U_pbinding
+import U_qid
+import U_tree
+import U_ttype
+
+import UgenUtil
+\end{code}
--- /dev/null
+Glues lots of things together for ugen-generated
+.hs files here
+
+\begin{code}
+#include "HsVersions.h"
+
+module UgenUtil (
+ -- re-exported Prelude stuff
+ returnPrimIO, thenPrimIO,
+
+ -- stuff defined here
+ UgenUtil..,
+
+ -- complete interface
+ ProtoName
+ ) where
+
+import PreludeGlaST
+
+import Ubiq{-uitous-}
+
+import MainMonad ( MainIO(..) )
+import ProtoName ( ProtoName(..) )
+import SrcLoc ( mkSrcLoc2 )
+
+--import ProtoName
+--import Outputable
+--import Util
+\end{code}
+
+\begin{code}
+type UgnM a
+ = FAST_STRING -- source file name; carried down
+ -> PrimIO a
+
+{-# INLINE returnUgn #-}
+{-# INLINE thenUgn #-}
+
+returnUgn x mod = returnPrimIO x
+
+thenUgn x y mod
+ = x mod `thenPrimIO` \ z ->
+ y z mod
+
+initUgn :: FAST_STRING -> UgnM a -> MainIO a
+initUgn srcfile action
+ = action srcfile `thenPrimIO` \ result ->
+ return result
+
+ioToUgnM :: PrimIO a -> UgnM a
+ioToUgnM x mod = x
+\end{code}
+
+\begin{code}
+type ParseTree = _Addr
+
+type U_VOID_STAR = _Addr
+rdU_VOID_STAR :: _Addr -> UgnM U_VOID_STAR
+rdU_VOID_STAR x = returnUgn x
+
+type U_long = Int
+rdU_long :: Int -> UgnM U_long
+rdU_long x = returnUgn x -- (A# x) = returnUgn (I# (addr2Int# x))
+
+type U_unkId = ProtoName
+rdU_unkId :: _Addr -> UgnM U_unkId
+rdU_unkId x
+ = rdU_stringId x `thenUgn` \ y ->
+ returnUgn (Unk y)
+
+type U_stringId = FAST_STRING
+rdU_stringId :: _Addr -> UgnM U_stringId
+{-# INLINE rdU_stringId #-}
+rdU_stringId s
+ = -- ToDo (sometime): ioToUgnM (_ccall_ hash_index s) `thenUgn` \ (I# i) ->
+ returnUgn (_packCString s)
+
+type U_numId = Int -- ToDo: Int
+rdU_numId :: _Addr -> UgnM U_numId
+rdU_numId i = rdU_stringId i `thenUgn` \ y -> returnUgn ((read (_UNPK_ y))::Int)
+
+type U_hstring = FAST_STRING
+rdU_hstring :: _Addr -> UgnM U_hstring
+rdU_hstring x
+ = ioToUgnM (_ccall_ get_hstring_len x) `thenUgn` \ len ->
+ ioToUgnM (_ccall_ get_hstring_bytes x) `thenUgn` \ bytes ->
+ returnUgn (_packCBytes len bytes)
+\end{code}
+
+\begin{code}
+setSrcFileUgn :: FAST_STRING{-filename-} -> UgnM a -> UgnM a
+setSrcFileUgn file action _ = action file
+
+getSrcFileUgn :: UgnM FAST_STRING{-filename-}
+getSrcFileUgn mod = returnUgn mod mod
+
+mkSrcLocUgn :: U_long -> UgnM SrcLoc
+mkSrcLocUgn ln mod
+ = returnUgn (mkSrcLoc2 mod ln) mod
+\end{code}
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_binding where
+import Ubiq -- debugging consistency check
+import UgenUtil
+
+import U_constr
+import U_coresyn ( U_coresyn ) -- for interfaces only
+import U_hpragma
+import U_list
+import U_literal ( U_literal ) -- for interfaces only
+import U_maybe
+import U_qid
+import U_ttype
+%}}
+type binding;
+ tbind : < gtbindc : list; /* [context entries] */
+ gtbindid : ttype; /* applied tycon */
+ gtbindl : list; /* [constr] */
+ gtbindd : maybe; /* Maybe [deriving] */
+ gtline : long;
+ gtpragma : hpragma; >;
+ ntbind : < gntbindc : list; /* [context entries] */
+ gntbindid : ttype; /* applied tycon */
+ gntbindcty : list; /* [constr] (only 1 constrnew) */
+ gntbindd : maybe; /* Maybe [deriving] */
+ gntline : long;
+ gntpragma : hpragma; >;
+ nbind : < gnbindid : ttype;
+ gnbindas : ttype;
+ gnline : long; >;
+ pbind : < gpbindl : list;
+ gpline : long; >;
+ fbind : < gfbindl : list;
+ gfline : long; >;
+ abind : < gabindfst : binding;
+ gabindsnd : binding; >;
+ ibind : < gibindsrc : long; /* 1 => source; 0 => interface */
+ gibindmod : stringId; /* the original module */
+ gibindc : list;
+ gibindid : qid;
+ gibindi : ttype;
+ gibindw : binding;
+ giline : long;
+ gipragma : hpragma; >;
+ dbind : < gdbindts : list;
+ gdline : long; >;
+ cbind : < gcbindc : list;
+ gcbindid : ttype;
+ gcbindw : binding;
+ gcline : long;
+ gcpragma : hpragma; >;
+ sbind : < gsbindids : list;
+ gsbindid : ttype;
+ gsline : long;
+ gspragma : hpragma; >;
+
+ mbind : < gmbindmodn : stringId; /* import (in an interface) <mod> <entities> */
+ gmbindimp : list; /* [entity] */
+ gmline : long; >;
+ mfbind : < gmfixes : list; >; /* fixites in an import: [fixop] */
+
+ nullbind : < >;
+
+ import : < gibindiface : stringId;
+ gibindfile : stringId;
+ gibinddef : binding;
+ gibindimod : stringId;
+ gibindqual : long;
+ gibindas : maybe;
+ gibindspec : maybe;
+ gibindline : long; >;
+
+ /* user-specified pragmas:XXXX */
+
+ vspec_uprag : < gvspec_id : qid;
+ gvspec_tys : list;
+ gvspec_line : long; >;
+
+ vspec_ty_and_id : < gvspec_ty : ttype;
+ gvspec_tyid : maybe; /* nil or singleton */ >;
+
+ ispec_uprag : < gispec_clas : qid;
+ gispec_ty : ttype;
+ gispec_line : long; >;
+
+ inline_uprag: < ginline_id : qid;
+ ginline_line : long; >;
+
+ deforest_uprag: < gdeforest_id : qid;
+ gdeforest_line : long; >;
+
+ magicuf_uprag:< gmagicuf_id : qid;
+ gmagicuf_str : stringId;
+ gmagicuf_line : long; >;
+
+ dspec_uprag : < gdspec_id : qid;
+ gdspec_tys : list;
+ gdspec_line : long; >;
+
+end;
--- /dev/null
+/*
+ Include File for the Lexical Analyser and Parser.
+
+ 19/11/91 kh Created.
+*/
+
+
+#ifndef __CONSTANTS_H
+#define __CONSTANTS_H
+
+/*
+ Important Literal Constants.
+*/
+
+#define MODNAME_SIZE 512 /* Size of Module Name buffers */
+#define FILENAME_SIZE 4096 /* Size of File buffers */
+#define ERR_BUF_SIZE 512 /* Size of error buffers */
+
+#ifdef YYLMAX /* Get rid of YYLMAX */
+#undef YYLMAX /* Ugly -- but necessary */
+#endif
+
+#define YYLMAX 8192 /* Size of yytext -- limits strings, identifiers etc. */
+
+
+#define HASH_TABLE_SIZE 993 /* Default number of entries in the hash table. */
+
+#define MAX_CONTEXTS 100 /* Maximum nesting of wheres, cases etc */
+
+#define MAX_INFIX 500 /* Maximum number of infix operators */
+
+#define MAX_ESC_CHAR 255 /* Largest Recognised Character: \255 */
+#define MAX_ESC_DIGITS 10 /* Maximum number of digits in an escape \dd */
+
+
+#ifdef TRUE
+#undef TRUE
+#endif
+
+#ifdef FALSE
+#undef FALSE
+#endif
+
+#define TRUE 1
+#define FALSE 0
+typedef int BOOLEAN;
+
+#endif /* __CONSTANTS_H */
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_constr where
+import Ubiq -- debugging consistency check
+import UgenUtil
+
+import U_maybe
+import U_list
+import U_qid
+import U_ttype
+%}}
+type constr;
+ /* constr in prefix form: */
+ constrpre : < gconcid : qid;
+ gconctypel : list; /* [ttype] */
+ gconcline : long; >;
+
+ /* constr in infix form: */
+ constrinf : < gconity1 : ttype;
+ gconiop : qid;
+ gconity2 : ttype;
+ gconiline : long; >;
+
+ /* constr in record form: */
+ constrrec : < gconrid : qid;
+ gconrfieldl : list; /* [field] */
+ gconrline : long; >;
+
+ /* constr in simple "newtype" form: */
+ constrnew : < gconnid : qid;
+ gconnty : ttype;
+ gconnline : long; >;
+
+ field : < gfieldn : list;
+ gfieldt : ttype; >;
+end;
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_coresyn where
+import Ubiq -- debugging consistency check
+import UgenUtil
+
+import U_list
+import U_literal
+import U_qid ( U_qid ) -- for interfaces only
+import U_ttype
+%}}
+type coresyn;
+ /* binders: simple Id, plus a type */
+ cobinder : < gcobinder_v : unkId;
+ gcobinder_ty : ttype; >;
+
+ /* atoms */
+ colit : < gcolit : literal; >;
+ colocal : < gcolocal_v : coresyn; >;
+
+ cononrec : <gcononrec_b : coresyn;
+ gcononrec_rhs : coresyn; >;
+ corec : <gcorec : list; >;
+ corec_pair: <gcorec_b : coresyn;
+ gcorec_rhs : coresyn; >;
+
+ covar : < gcovar : coresyn; >;
+ coliteral :< gcoliteral : literal; >;
+ cocon : < gcocon_con : coresyn;
+ gcocon_tys : list;
+ gcocon_args : list; >;
+ coprim : < gcoprim_op : coresyn; /* primop or something */
+ gcoprim_tys : list;
+ gcoprim_args: list; >;
+ colam : < gcolam_vars : list;
+ gcolam_body : coresyn; >;
+ cotylam : < gcotylam_tvs: list;
+ gcotylam_body : coresyn; >;
+ coapp : < gcoapp_fun : coresyn;
+ gcoapp_args : list; >;
+ cotyapp : < gcotyapp_e : coresyn;
+ gcotyapp_t : ttype; >;
+ cocase : < gcocase_s : coresyn;
+ gcocase_alts : coresyn; >;
+ colet : < gcolet_bind : coresyn;
+ gcolet_body : coresyn; >;
+ coscc : < gcoscc_scc : coresyn;
+ gcoscc_body : coresyn; >;
+
+ coalg_alts : < gcoalg_alts : list;
+ gcoalg_deflt : coresyn; >;
+ coalg_alt : < gcoalg_con : coresyn;
+ gcoalg_bs : list;
+ gcoalg_rhs : coresyn; >;
+
+ coprim_alts : < gcoprim_alts : list;
+ gcoprim_deflt : coresyn; >;
+ coprim_alt : < gcoprim_lit : literal;
+ gcoprim_rhs : coresyn; >;
+
+ conodeflt : < >;
+ cobinddeflt : < gcobinddeflt_v : coresyn;
+ gcobinddeflt_rhs : coresyn; >;
+
+ co_primop : < gco_primop : stringId;>;
+ co_ccall : < gco_ccall : stringId;
+ gco_ccall_may_gc : long;
+ gco_ccall_arg_tys : list;
+ gco_ccall_res_ty : ttype; >;
+ co_casm : < gco_casm : literal;
+ gco_casm_may_gc : long;
+ gco_casm_arg_tys : list;
+ gco_casm_res_ty : ttype; >;
+
+ /* various flavours of cost-centres */
+ co_preludedictscc : < gco_preludedictscc_dupd : coresyn; >;
+ co_alldictscc : < gco_alldictscc_m : hstring;
+ gco_alldictscc_g : hstring;
+ gco_alldictscc_dupd : coresyn; >;
+ co_usercc : < gco_usercc_n : hstring;
+ gco_usercc_m : hstring;
+ gco_usercc_g : hstring;
+ gco_usercc_dupd : coresyn;
+ gco_usercc_cafd : coresyn; >;
+ co_autocc : < gco_autocc_i : coresyn;
+ gco_autocc_m : hstring;
+ gco_autocc_g : hstring;
+ gco_autocc_dupd : coresyn;
+ gco_autocc_cafd : coresyn; >;
+ co_dictcc : < gco_dictcc_i : coresyn;
+ gco_dictcc_m : hstring;
+ gco_dictcc_g : hstring;
+ gco_dictcc_dupd : coresyn;
+ gco_dictcc_cafd : coresyn; >;
+
+ co_scc_noncaf : < >;
+ co_scc_caf : < >;
+ co_scc_nondupd : < >;
+ co_scc_dupd : < >;
+
+ /* various flavours of Ids */
+ co_id : < gco_id : stringId; >;
+ co_orig_id : < gco_orig_id_m : stringId;
+ gco_orig_id_n : stringId; >;
+ co_sdselid : < gco_sdselid_c : unkId;
+ gco_sdselid_sc : unkId; >;
+ co_classopid : < gco_classopid_c : unkId;
+ gco_classopid_o : unkId; >;
+ co_defmid : < gco_defmid_c : unkId;
+ gco_defmid_op : unkId; >;
+ co_dfunid : < gco_dfunid_c : unkId;
+ gco_dfunid_ty : ttype; >;
+ co_constmid : < gco_constmid_c : unkId;
+ gco_constmid_op : unkId;
+ gco_constmid_ty : ttype; >;
+ co_specid : < gco_specid_un : coresyn;
+ gco_specid_tys : list; >;
+ co_wrkrid : < gco_wrkrid_un : coresyn; >;
+end;
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_either where
+import Ubiq -- debugging consistency check
+import UgenUtil
+%}}
+type either;
+ left : < gleft : VOID_STAR; > ;
+ right : < gright : VOID_STAR; > ;
+end;
+
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_entidt where
+import Ubiq -- debugging consistency check
+import UgenUtil
+
+import U_list
+import U_qid
+%}}
+type entidt;
+ entid : < gentid : qid; >;
+ enttype : < gtentid : qid; >;
+ enttypeall : < gaentid : qid; >;
+ enttypenamed : < gnentid : qid;
+ gnentnames : list; >;
+ entmod : < gmentid : stringId; >;
+end;
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_hpragma where
+import Ubiq -- debugging consistency check
+import UgenUtil
+
+import U_coresyn
+import U_list
+import U_literal ( U_literal ) -- ditto
+import U_ttype ( U_ttype ) -- interface only
+%}}
+type hpragma;
+ no_pragma: < > ;
+
+ idata_pragma: < gprag_data_constrs : list; /*of con decls*/
+ gprag_data_specs : list; /*specialisations*/ >;
+
+ itype_pragma: < >;
+
+ iclas_pragma: < gprag_clas : list; /*of gen pragmas*/ >;
+
+ iclasop_pragma: < gprag_dsel : hpragma; /* gen pragma: dict selector */
+ gprag_defm : hpragma; /* gen pragma: default method */ >;
+
+ iinst_simpl_pragma: < gprag_dfun_simpl : hpragma; /* gen pragma: of dfun */ >;
+
+ iinst_const_pragma: < gprag_dfun_const : hpragma; /* gen pragma: of dfun */
+ gprag_constms : list; /* (name, gen pragma) pairs */ >;
+
+ igen_pragma: < gprag_arity : hpragma; /* arity */
+ gprag_update : hpragma; /* update info */
+ gprag_deforest : hpragma; /* deforest info */
+ gprag_strictness : hpragma; /* strictness info */
+ gprag_unfolding : hpragma; /* unfolding */
+ gprag_specs : list; /* (type, gen pragma) pairs */ >;
+
+ iarity_pragma: < gprag_arity_val : numId; >;
+ iupdate_pragma: < gprag_update_val : stringId; >;
+ ideforest_pragma: < >;
+ istrictness_pragma: < gprag_strict_spec : hstring;
+ gprag_strict_wrkr : hpragma; /*about worker*/ >;
+ imagic_unfolding_pragma: < gprag_magic_str : stringId; >;
+
+ iunfolding_pragma: < gprag_unfold_guide : hpragma; /* guidance */
+ gprag_unfold_core : coresyn; >;
+
+ iunfold_always: < >;
+ iunfold_if_args: < gprag_unfold_if_t_args : numId;
+ gprag_unfold_if_v_args : numId;
+ gprag_unfold_if_con_args : stringId;
+ gprag_unfold_if_size : numId; >;
+
+ iname_pragma_pr: < gprag_name_pr1 : unkId;
+ gprag_name_pr2 : hpragma; >;
+ itype_pragma_pr: < gprag_type_pr1 : list; /* of maybe types */
+ gprag_type_pr2 : numId; /* # dicts to ignore */
+ gprag_type_pr3 : hpragma; >;
+
+ idata_pragma_4s: < gprag_data_spec : list; /* of maybe types */ >;
+
+end;
--- /dev/null
+/*
+These routines customise the error messages
+for various bits of the RTS. They are linked
+in instead of the defaults.
+*/
+#include <stdio.h>
+
+#define W_ unsigned long int
+#define I_ long int
+
+void
+ErrorHdrHook (where)
+ FILE *where;
+{
+ fprintf(where, "\n"); /* no "Fail: " */
+}
+
+
+void
+OutOfHeapHook (request_size, heap_size)
+ W_ request_size; /* in bytes */
+ W_ heap_size; /* in bytes */
+{
+ fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
+ request_size,
+ heap_size);
+}
+
+void
+StackOverflowHook (stack_size)
+ I_ stack_size; /* in bytes */
+{
+ fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
+}
+
+#if 0
+/* nothing to add here, really */
+void
+MallocFailHook (request_size, msg)
+ I_ request_size; /* in bytes */
+ char *msg;
+{
+ fprintf(stderr, "malloc: failed on request for %lu bytes\n", request_size);
+}
+#endif /* 0 */
+
+void
+PatErrorHdrHook (where)
+ FILE *where;
+{
+ fprintf(where, "\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\nFail: ");
+}
+
+void
+PreTraceHook (where)
+ FILE *where;
+{
+ fprintf(where, "\n"); /* not "Trace On" */
+}
+
+void
+PostTraceHook (where)
+ FILE *where;
+{
+ fprintf(where, "\n"); /* not "Trace Off" */
+}
--- /dev/null
+/* This is the "top-level" file for the *linked-into-the-compiler* parser.
+ See also main.c. (WDP 94/10)
+*/
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+/**********************************************************************
+* *
+* *
+* The main program *
+* *
+* *
+**********************************************************************/
+
+extern long prog_argc;
+extern char **prog_argv;
+
+#define MAX_HSP_ARGS 64
+long hsp_argc;
+char *hsp_argv[MAX_HSP_ARGS]; /* sigh */
+
+tree
+hspmain()
+{
+ int hsp_i, prog_i;
+
+ Lnil = mklnil(); /* The null list -- used in lsing, etc. */
+
+ /* copy the args we're interested in (first char: comma)
+ to hsp_argv; arrange to point after the comma!
+ */
+ hsp_i = 0;
+ for (prog_i = 0; prog_i < prog_argc; prog_i++) {
+ if (prog_argv[prog_i][0] == ',') {
+ hsp_argv[hsp_i] = &(prog_argv[prog_i][1]);
+ hsp_i++;
+ }
+ }
+ hsp_argc = hsp_i; /* set count */
+
+ process_args(hsp_argc, hsp_argv); /* HACK */
+
+ hash_init();
+
+#ifdef HSP_DEBUG
+ fprintf(stderr,"input_file_dir=%s\n",input_file_dir);
+#endif
+
+ yyinit();
+
+ if (yyparse() != 0) {
+ /* There was a syntax error. */
+ printf("\n");
+ exit(1);
+ }
+
+ return(root);
+}
--- /dev/null
+%{
+/**********************************************************************
+* *
+* *
+* FLEX for Haskell. *
+* ----------------- *
+* *
+**********************************************************************/
+
+#include "../../includes/config.h"
+
+#include <stdio.h>
+
+#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
+#include <string.h>
+/* An ANSI string.h and pre-ANSI memory.h might conflict. */
+#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
+#include <memory.h>
+#endif /* not STDC_HEADERS and HAVE_MEMORY_H */
+#define index strchr
+#define rindex strrchr
+#define bcopy(s, d, n) memcpy ((d), (s), (n))
+#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
+#define bzero(s, n) memset ((s), 0, (n))
+#else /* not STDC_HEADERS and not HAVE_STRING_H */
+#include <strings.h>
+/* memory.h and strings.h conflict on some systems. */
+#endif /* not STDC_HEADERS and not HAVE_STRING_H */
+
+#include "hspincl.h"
+#include "hsparser.tab.h"
+#include "constants.h"
+#include "utils.h"
+
+/* Our substitute for <ctype.h> */
+
+#define NCHARS 256
+#define _S 0x1
+#define _D 0x2
+#define _H 0x4
+#define _O 0x8
+#define _C 0x10
+
+#define _isconstr(s) (CharTable[*s]&(_C))
+BOOLEAN isconstr PROTO((char *)); /* fwd decl */
+
+static unsigned char CharTable[NCHARS] = {
+/* nul */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* bs */ 0, _S, _S, _S, _S, 0, 0, 0,
+/* dle */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* can */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* sp */ _S, 0, 0, 0, 0, 0, 0, 0,
+/* '(' */ _C, 0, 0, 0, 0, 0, 0, 0, /* ( */
+/* '0' */ _D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,
+/* '8' */ _D|_H, _D|_H, _C, 0, 0, 0, 0, 0,
+/* '@' */ 0, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _C,
+/* 'H' */ _C, _C, _C, _C, _C, _C, _C, _C,
+/* 'P' */ _C, _C, _C, _C, _C, _C, _C, _C,
+/* 'X' */ _C, _C, _C, _C, 0, 0, 0, 0, /* [ */
+/* '`' */ 0, _H, _H, _H, _H, _H, _H, 0,
+/* 'h' */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* 'p' */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* 'x' */ 0, 0, 0, 0, 0, 0, 0, 0,
+
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+/* */ 0, 0, 0, 0, 0, 0, 0, 0,
+};
+
+/**********************************************************************
+* *
+* *
+* Declarations *
+* *
+* *
+**********************************************************************/
+
+char *input_filename = NULL; /* Always points to a dynamically allocated string */
+
+/*
+ * For my own sanity, things that are not part of the flex skeleton
+ * have been renamed as hsXXXXX rather than yyXXXXX. --JSM
+ */
+
+static int hslineno = 0; /* Line number at end of token */
+int hsplineno = 0; /* Line number at end of previous token */
+
+static int hscolno = 0; /* Column number at end of token */
+int hspcolno = 0; /* Column number at end of previous token */
+static int hsmlcolno = 0; /* Column number for multiple-rule lexemes */
+
+int modulelineno = -1; /* The line number where the module starts */
+int startlineno = 0; /* The line number where something starts */
+int endlineno = 0; /* The line number where something ends */
+
+static BOOLEAN noGap = TRUE; /* For checking string gaps */
+static BOOLEAN forgetindent = FALSE; /* Don't bother applying indentation rules */
+
+static int nested_comments; /* For counting comment nesting depth */
+
+/* Hacky definition of yywrap: see flex doc.
+
+ If we don't do this, then we'll have to get the default
+ yywrap from the flex library, which is often something
+ we are not good at locating. This avoids that difficulty.
+ (Besides which, this is the way old flexes (pre 2.4.x) did it.)
+ WDP 94/09/05
+*/
+#define yywrap() 1
+
+/* Essential forward declarations */
+
+static void hsnewid PROTO((char *, int));
+static void layout_input PROTO((char *, int));
+static void cleartext (NO_ARGS);
+static void addtext PROTO((char *, unsigned));
+static void addchar PROTO((char));
+static char *fetchtext PROTO((unsigned *));
+static void new_filename PROTO((char *));
+static int Return PROTO((int));
+static void hsentercontext PROTO((int));
+
+/* Special file handling for IMPORTS */
+/* Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */
+
+static YY_BUFFER_STATE hsbuf_save = NULL; /* Saved input buffer */
+static char *filename_save; /* File Name */
+static int hslineno_save = 0, /* Line Number */
+ hsplineno_save = 0, /* Line Number of Prev. token */
+ hscolno_save = 0, /* Indentation */
+ hspcolno_save = 0; /* Left Indentation */
+static short icontexts_save = 0; /* Indent Context Level */
+
+static BOOLEAN etags_save; /* saved: whether doing etags stuff or not */
+extern BOOLEAN etags; /* that which is saved */
+
+extern BOOLEAN nonstandardFlag; /* Glasgow extensions allowed */
+
+static BOOLEAN in_interface = FALSE; /* TRUE if we are reading a .hi file */
+
+extern BOOLEAN ignorePragmas; /* True when we should ignore pragmas */
+extern int minAcceptablePragmaVersion; /* see documentation in main.c */
+extern int maxAcceptablePragmaVersion;
+extern int thisIfacePragmaVersion;
+
+static int hssttok = -1; /* Stacked Token: -1 -- no token; -ve -- ";"
+ * inserted before token +ve -- "}" inserted before
+ * token */
+
+short icontexts = 0; /* Which context we're in */
+
+
+
+/*
+ Table of indentations: right bit indicates whether to use
+ indentation rules (1 = use rules; 0 = ignore)
+
+ partain:
+ push one of these "contexts" at every "case" or "where"; the right bit says
+ whether user supplied braces, etc., or not. pop appropriately (hsendindent).
+
+ ALSO, a push/pop when enter/exit a new file (e.g., on importing). A -1 is
+ pushed (the "column" for "module", "interface" and EOF). The -1 from the initial
+ push is shown just below.
+
+*/
+
+
+static short indenttab[MAX_CONTEXTS] = {-1};
+
+#define INDENTPT (indenttab[icontexts]>>1)
+#define INDENTON (indenttab[icontexts]&1)
+
+#define RETURN(tok) return(Return(tok))
+
+#undef YY_DECL
+#define YY_DECL int yylex1()
+
+/* We should not peek at yy_act, but flex calls us even for the internal action
+ triggered on 'end-of-buffer' (This is not true of flex 2.4.4 and up, but
+ to support older versions of flex, we'll continue to peek for now.
+ */
+#define YY_USER_ACTION \
+ if (yy_act != YY_END_OF_BUFFER) layout_input(yytext, yyleng);
+
+#if 0/*debug*/
+#undef YY_BREAK
+#define YY_BREAK if (etags) fprintf(stderr,"%d %d / %d %d / %d\n",hsplineno,hspcolno,hslineno,hscolno,startlineno); break;
+#endif
+
+/* Each time we enter a new start state, we push it onto the state stack.
+ Note that the rules do not allow us to underflow or overflow the stack.
+ (At least, they shouldn't.) The maximum expected depth is 4:
+ 0: Code -> 1: String -> 2: StringEsc -> 3: Comment
+*/
+static int StateStack[5];
+static int StateDepth = -1;
+
+#ifdef HSP_DEBUG
+#define PUSH_STATE(n) do {\
+ fprintf(stderr,"Pushing %d (%d)\n", n, StateDepth + 1);\
+ StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
+#define POP_STATE do {--StateDepth;\
+ fprintf(stderr,"Popping %d (%d)\n", StateStack[StateDepth], StateDepth);\
+ BEGIN(StateStack[StateDepth]);} while(0)
+#else
+#define PUSH_STATE(n) do {StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
+#define POP_STATE do {--StateDepth; BEGIN(StateStack[StateDepth]);} while(0)
+#endif
+
+%}
+
+/* The start states are:
+ Code -- normal Haskell code (principal lexer)
+ GlaExt -- Haskell code with Glasgow extensions
+ Comment -- Nested comment processing
+ String -- Inside a string literal with backslashes
+ StringEsc -- Immediately following a backslash in a string literal
+ Char -- Inside a character literal with backslashes
+ CharEsc -- Immediately following a backslash in a character literal
+
+ Note that the INITIAL state is unused. Also note that these states
+ are _exclusive_. All rules should be prefixed with an appropriate
+ list of start states.
+ */
+
+%x Char CharEsc Code Comment GlaExt GhcPragma UserPragma String StringEsc
+
+isoS [\xa1-\xbf\xd7\xf7]
+isoL [\xc0-\xd6\xd8-\xde]
+isol [\xdf-\xf6\xf8-\xff]
+isoA [\xa1-\xff]
+
+D [0-9]
+O [0-7]
+H [0-9A-Fa-f]
+N {D}+
+F {N}"."{N}(("e"|"E")("+"|"-")?{N})?
+S [!#$%&*+./<=>?@\\^|-~:\xa1-\xbf\xd7\xf7]
+SId {S}{S}*
+L [A-Z\xc0-\xd6\xd8-\xde]
+l [a-z\xdf-\xf6\xf8-\xff]
+I {L}|{l}
+i {L}|{l}|[0-9'_]
+Id {I}{i}*
+Mod {L}{i}*
+CHAR [ !#$%&()*+,\-./0-9:;<=>?@A-Z\[\]^_`a-z{|}~\xa1-\xff]
+CNTRL [@A-Z\[\\\]^_]
+WS [ \t\n\r\f\v]
+NL [\n\r]
+
+%%
+
+%{
+ /*
+ * Special GHC pragma rules. Do we need a start state for interface files,
+ * so these won't be matched in source files? --JSM
+ */
+%}
+
+<Code,GlaExt>^"# ".*{NL} {
+ char tempf[FILENAME_SIZE];
+ sscanf(yytext+1, "%d \"%[^\"]", &hslineno, tempf);
+ new_filename(tempf);
+ hsplineno = hslineno; hscolno = 0; hspcolno = 0;
+ }
+
+<Code,GlaExt>^"#line ".*{NL} {
+ char tempf[FILENAME_SIZE];
+ sscanf(yytext+5, "%d \"%[^\"]", &hslineno, tempf);
+ new_filename(tempf);
+ hsplineno = hslineno; hscolno = 0; hspcolno = 0;
+ }
+
+<Code,GlaExt>"{-# LINE ".*"-}"{NL} {
+ /* partain: pragma-style line directive */
+ char tempf[FILENAME_SIZE];
+ sscanf(yytext+9, "%d \"%[^\"]", &hslineno, tempf);
+ new_filename(tempf);
+ hsplineno = hslineno; hscolno = 0; hspcolno = 0;
+ }
+<Code,GlaExt>"{-# GHC_PRAGMA INTERFACE VERSION "{D}+" #-}" {
+ sscanf(yytext+33,"%d ",&thisIfacePragmaVersion);
+ }
+<Code,GlaExt>"{-# GHC_PRAGMA " {
+ if ( ignorePragmas ||
+ thisIfacePragmaVersion < minAcceptablePragmaVersion ||
+ thisIfacePragmaVersion > maxAcceptablePragmaVersion) {
+ nested_comments = 1;
+ PUSH_STATE(Comment);
+ } else {
+ PUSH_STATE(GhcPragma);
+ RETURN(GHC_PRAGMA);
+ }
+ }
+<GhcPragma>"_N_" { RETURN(NO_PRAGMA); }
+<GhcPragma>"_NI_" { RETURN(NOINFO_PRAGMA); }
+<GhcPragma>"_DEFOREST_" { RETURN(DEFOREST_PRAGMA); }
+<GhcPragma>"_SPECIALISE_" { RETURN(SPECIALISE_PRAGMA); }
+<GhcPragma>"_A_" { RETURN(ARITY_PRAGMA); }
+<GhcPragma>"_U_" { RETURN(UPDATE_PRAGMA); }
+<GhcPragma>"_S_" { RETURN(STRICTNESS_PRAGMA); }
+<GhcPragma>"_K_" { RETURN(KIND_PRAGMA); }
+<GhcPragma>"_MF_" { RETURN(MAGIC_UNFOLDING_PRAGMA); }
+<GhcPragma>"_F_" { RETURN(UNFOLDING_PRAGMA); }
+
+<GhcPragma>"_!_" { RETURN(COCON); }
+<GhcPragma>"_#_" { RETURN(COPRIM); }
+<GhcPragma>"_APP_" { RETURN(COAPP); }
+<GhcPragma>"_TYAPP_" { RETURN(COTYAPP); }
+<GhcPragma>"_ALG_" { RETURN(CO_ALG_ALTS); }
+<GhcPragma>"_PRIM_" { RETURN(CO_PRIM_ALTS); }
+<GhcPragma>"_NO_DEFLT_" { RETURN(CO_NO_DEFAULT); }
+<GhcPragma>"_LETREC_" { RETURN(CO_LETREC); }
+
+<GhcPragma>"_PRELUDE_DICTS_CC_" { RETURN(CO_PRELUDE_DICTS_CC); }
+<GhcPragma>"_ALL_DICTS_CC_" { RETURN(CO_ALL_DICTS_CC); }
+<GhcPragma>"_USER_CC_" { RETURN(CO_USER_CC); }
+<GhcPragma>"_AUTO_CC_" { RETURN(CO_AUTO_CC); }
+<GhcPragma>"_DICT_CC_" { RETURN(CO_DICT_CC); }
+
+<GhcPragma>"_DUPD_CC_" { RETURN(CO_DUPD_CC); }
+<GhcPragma>"_CAF_CC_" { RETURN(CO_CAF_CC); }
+
+<GhcPragma>"_SDSEL_" { RETURN(CO_SDSEL_ID); }
+<GhcPragma>"_METH_" { RETURN(CO_METH_ID); }
+<GhcPragma>"_DEFM_" { RETURN(CO_DEFM_ID); }
+<GhcPragma>"_DFUN_" { RETURN(CO_DFUN_ID); }
+<GhcPragma>"_CONSTM_" { RETURN(CO_CONSTM_ID); }
+<GhcPragma>"_SPEC_" { RETURN(CO_SPEC_ID); }
+<GhcPragma>"_WRKR_" { RETURN(CO_WRKR_ID); }
+<GhcPragma>"_ORIG_" { RETURN(CO_ORIG_NM); /* fully-qualified original name*/ }
+
+<GhcPragma>"_ALWAYS_" { RETURN(UNFOLD_ALWAYS); }
+<GhcPragma>"_IF_ARGS_" { RETURN(UNFOLD_IF_ARGS); }
+
+<GhcPragma>"_NOREP_I_" { RETURN(NOREP_INTEGER); }
+<GhcPragma>"_NOREP_R_" { RETURN(NOREP_RATIONAL); }
+<GhcPragma>"_NOREP_S_" { RETURN(NOREP_STRING); }
+
+<GhcPragma>" #-}" { POP_STATE; RETURN(END_PRAGMA); }
+
+<Code,GlaExt>"{-#"{WS}*"SPECIALI"[SZ]E {
+ PUSH_STATE(UserPragma);
+ RETURN(SPECIALISE_UPRAGMA);
+ }
+<Code,GlaExt>"{-#"{WS}*"INLINE" {
+ PUSH_STATE(UserPragma);
+ RETURN(INLINE_UPRAGMA);
+ }
+<Code,GlaExt>"{-#"{WS}*"MAGIC_UNFOLDING" {
+ PUSH_STATE(UserPragma);
+ RETURN(MAGIC_UNFOLDING_UPRAGMA);
+ }
+<Code,GlaExt>"{-#"{WS}*"DEFOREST" {
+ PUSH_STATE(UserPragma);
+ RETURN(DEFOREST_UPRAGMA);
+ }
+<Code,GlaExt>"{-#"{WS}*[A-Z_]+ {
+ fprintf(stderr, "Warning: \"%s\", line %d: Unrecognised pragma '",
+ input_filename, hsplineno);
+ format_string(stderr, (unsigned char *) yytext, yyleng);
+ fputs("'\n", stderr);
+ nested_comments = 1;
+ PUSH_STATE(Comment);
+ }
+<UserPragma>"#-}" { POP_STATE; RETURN(END_UPRAGMA); }
+
+%{
+ /*
+ * Haskell keywords. `scc' is actually a Glasgow extension, but it is
+ * intentionally accepted as a keyword even for normal <Code>.
+ */
+%}
+
+<Code,GlaExt,GhcPragma>"case" { RETURN(CASE); }
+<Code,GlaExt>"class" { RETURN(CLASS); }
+<Code,GlaExt,UserPragma>"data" { RETURN(DATA); }
+<Code,GlaExt>"default" { RETURN(DEFAULT); }
+<Code,GlaExt>"deriving" { RETURN(DERIVING); }
+<Code,GlaExt>"do" { RETURN(DO); }
+<Code,GlaExt>"else" { RETURN(ELSE); }
+<Code,GlaExt>"if" { RETURN(IF); }
+<Code,GlaExt>"import" { RETURN(IMPORT); }
+<Code,GlaExt,GhcPragma>"in" { RETURN(IN); }
+<Code,GlaExt>"infix" { RETURN(INFIX); }
+<Code,GlaExt>"infixl" { RETURN(INFIXL); }
+<Code,GlaExt>"infixr" { RETURN(INFIXR); }
+<Code,GlaExt,UserPragma>"instance" { RETURN(INSTANCE); }
+<Code,GlaExt,GhcPragma>"let" { RETURN(LET); }
+<Code,GlaExt>"module" { RETURN(MODULE); }
+<Code,GlaExt>"newtype" { RETURN(NEWTYPE); }
+<Code,GlaExt,GhcPragma>"of" { RETURN(OF); }
+<Code,GlaExt>"then" { RETURN(THEN); }
+<Code,GlaExt>"type" { RETURN(TYPE); }
+<Code,GlaExt>"where" { RETURN(WHERE); }
+
+<Code,GlaExt>"as" { RETURN(AS); }
+<Code,GlaExt>"hiding" { RETURN(HIDING); }
+<Code,GlaExt>"qualified" { RETURN(QUALIFIED); }
+<Code,GlaExt>"interface" { RETURN(INTERFACE); }
+
+<Code,GlaExt,GhcPragma>"_scc_" { RETURN(SCC); }
+<GlaExt,GhcPragma>"_ccall_" { RETURN(CCALL); }
+<GlaExt,GhcPragma>"_ccall_GC_" { RETURN(CCALL_GC); }
+<GlaExt,GhcPragma>"_casm_" { RETURN(CASM); }
+<GlaExt,GhcPragma>"_casm_GC_" { RETURN(CASM_GC); }
+<GhcPragma>"_forall_" { RETURN(FORALL); }
+
+%{
+ /*
+ * Haskell operators: special, reservedops and useful varsyms
+ */
+%}
+
+<Code,GlaExt,GhcPragma,UserPragma>"(" { RETURN(OPAREN); }
+<Code,GlaExt,GhcPragma,UserPragma>")" { RETURN(CPAREN); }
+<Code,GlaExt,GhcPragma,UserPragma>"[" { RETURN(OBRACK); }
+<Code,GlaExt,GhcPragma,UserPragma>"]" { RETURN(CBRACK); }
+<Code,GlaExt,GhcPragma>"{" { RETURN(OCURLY); }
+<Code,GlaExt,GhcPragma>"}" { RETURN(CCURLY); }
+<Code,GlaExt,GhcPragma,UserPragma>"," { RETURN(COMMA); }
+<Code,GlaExt,GhcPragma>";" { RETURN(SEMI); }
+<Code,GlaExt,GhcPragma>"`" { RETURN(BQUOTE); }
+<Code,GlaExt>"_" { RETURN(WILDCARD); }
+
+<Code,GlaExt>".." { RETURN(DOTDOT); }
+<Code,GlaExt,GhcPragma,UserPragma>"::" { RETURN(DCOLON); }
+<Code,GlaExt,GhcPragma,UserPragma>"=" { RETURN(EQUAL); }
+<Code,GlaExt,GhcPragma>"\\" { RETURN(LAMBDA); }
+<Code,GlaExt,GhcPragma>"|" { RETURN(VBAR); }
+<Code,GlaExt>"<-" { RETURN(LARROW); }
+<Code,GlaExt,GhcPragma,UserPragma>"->" { RETURN(RARROW); }
+<Code,GlaExt>"-" { RETURN(MINUS); }
+
+<Code,GlaExt,GhcPragma,UserPragma>"=>" { RETURN(DARROW); }
+<Code,GlaExt>"@" { RETURN(AT); }
+<Code,GlaExt>"!" { RETURN(BANG); }
+<Code,GlaExt>"~" { RETURN(LAZY); }
+
+<GhcPragma>"_/\\_" { RETURN(TYLAMBDA); }
+
+%{
+ /*
+ * Integers and (for Glasgow extensions) primitive integers. Note that
+ * we pass all of the text on to the parser, because flex/C can't handle
+ * arbitrary precision numbers.
+ */
+%}
+
+<GlaExt>("-")?"0"[Oo]{O}+"#" { /* octal */
+ yylval.uid = xstrndup(yytext, yyleng - 1);
+ RETURN(INTPRIM);
+ }
+<Code,GlaExt>"0"[Oo]{O}+ { /* octal */
+ yylval.uid = xstrndup(yytext, yyleng);
+ RETURN(INTEGER);
+ }
+<GlaExt>("-")?"0"[Xx]{H}+"#" { /* hexadecimal */
+ yylval.uid = xstrndup(yytext, yyleng - 1);
+ RETURN(INTPRIM);
+ }
+<Code,GlaExt>"0"[Xx]{H}+ { /* hexadecimal */
+ yylval.uid = xstrndup(yytext, yyleng);
+ RETURN(INTEGER);
+ }
+<GlaExt,GhcPragma>("-")?{N}"#" {
+ yylval.uid = xstrndup(yytext, yyleng - 1);
+ RETURN(INTPRIM);
+ }
+<Code,GlaExt,GhcPragma>{N} {
+ yylval.uid = xstrndup(yytext, yyleng);
+ RETURN(INTEGER);
+ }
+
+%{
+ /*
+ * Floats and (for Glasgow extensions) primitive floats/doubles.
+ */
+%}
+
+<GlaExt,GhcPragma>("-")?{F}"##" {
+ yylval.uid = xstrndup(yytext, yyleng - 2);
+ RETURN(DOUBLEPRIM);
+ }
+<GlaExt,GhcPragma>("-")?{F}"#" {
+ yylval.uid = xstrndup(yytext, yyleng - 1);
+ RETURN(FLOATPRIM);
+ }
+<Code,GlaExt>{F} {
+ yylval.uid = xstrndup(yytext, yyleng);
+ RETURN(FLOAT);
+ }
+
+%{
+ /*
+ * Funky ``foo'' style C literals for Glasgow extensions
+ */
+%}
+
+<GlaExt,GhcPragma>"``"[^']+"''" {
+ hsnewid(yytext + 2, yyleng - 4);
+ RETURN(CLITLIT);
+ }
+
+%{
+ /*
+ * Identifiers, both variables and operators. The trailing hash is allowed
+ * for Glasgow extensions.
+ */
+%}
+
+<GhcPragma>"_NIL_" { hsnewid(yytext, yyleng); RETURN(CONID); }
+<GhcPragma>"_TUP_"{D}+ { hsnewid(yytext, yyleng); RETURN(CONID); }
+<GhcPragma>[a-z]{i}*"$"[a-z]{i}* { hsnewid(yytext, yyleng); RETURN(TYVAR_TEMPLATE_ID); }
+
+%{
+/* These SHOULDNAE work in "Code" (sigh) */
+%}
+<Code,GlaExt,GhcPragma,UserPragma>{Id}"#" {
+ if (! (nonstandardFlag || in_interface)) {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
+ hsperror(errbuf);
+ }
+ hsnewid(yytext, yyleng);
+ RETURN(_isconstr(yytext) ? CONID : VARID);
+ }
+<Code,GlaExt,GhcPragma,UserPragma>_+{Id} {
+ if (! (nonstandardFlag || in_interface)) {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext);
+ hsperror(errbuf);
+ }
+ hsnewid(yytext, yyleng);
+ RETURN(isconstr(yytext) ? CONID : VARID);
+ /* NB: ^^^^^^^^ : not the macro! */
+ }
+<Code,GlaExt,GhcPragma,UserPragma>{Id} {
+ hsnewid(yytext, yyleng);
+ RETURN(_isconstr(yytext) ? CONID : VARID);
+ }
+<Code,GlaExt,GhcPragma,UserPragma>{SId} {
+ hsnewid(yytext, yyleng);
+ RETURN(_isconstr(yytext) ? CONSYM : VARSYM);
+ }
+<Code,GlaExt,GhcPragma,UserPragma>{Mod}"."{Id} {
+ BOOLEAN isconstr = hsnewqid(yytext, yyleng);
+ RETURN(isconstr ? QCONID : QVARID);
+ }
+<Code,GlaExt,GhcPragma,UserPragma>{Mod}"."{SId} {
+ BOOLEAN isconstr = hsnewqid(yytext, yyleng);
+ RETURN(isconstr ? QCONSYM : QVARSYM);
+ }
+
+%{
+ /* Why is `{Id}#` matched this way, and `{Id}` lexed as three tokens? --JSM */
+
+ /* Because we can make the former well-behaved (we defined them).
+
+ Sadly, the latter is defined by Haskell, which allows such
+ la-la land constructs as `{-a 900-line comment-} foo`. (WDP 94/12)
+ */
+%}
+
+<GlaExt,GhcPragma,UserPragma>"`"{Id}"#`" {
+ hsnewid(yytext + 1, yyleng - 2);
+ RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM);
+ }
+
+%{
+ /*
+ * Character literals. The first form is the quick form, for character
+ * literals that don't contain backslashes. Literals with backslashes are
+ * lexed through multiple rules. First, we match the open ' and as many
+ * normal characters as possible. This puts us into the <Char> state, where
+ * a backslash is legal. Then, we match the backslash and move into the
+ * <CharEsc> state. When we drop out of <CharEsc>, we collect more normal
+ * characters and the close '. We may end up with too many characters, but
+ * this allows us to easily share the lex rules with strings. Excess characters
+ * are ignored with a warning.
+ */
+%}
+
+<GlaExt,GhcPragma>'({CHAR}|"\"")"'#" {
+ yylval.uhstring = installHstring(1, yytext+1);
+ RETURN(CHARPRIM);
+ }
+<Code,GlaExt>'({CHAR}|"\"")' {
+ yylval.uhstring = installHstring(1, yytext+1);
+ RETURN(CHAR);
+ }
+<Code,GlaExt>'' {char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf, "'' is not a valid character (or string) literal\n");
+ hsperror(errbuf);
+ }
+<Code,GlaExt,GhcPragma>'({CHAR}|"\"")* {
+ hsmlcolno = hspcolno;
+ cleartext();
+ addtext(yytext+1, yyleng-1);
+ PUSH_STATE(Char);
+ }
+<Char>({CHAR}|"\"")*'# {
+ unsigned length;
+ char *text;
+
+ addtext(yytext, yyleng - 2);
+ text = fetchtext(&length);
+
+ if (! (nonstandardFlag || in_interface)) {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf, "`Char-hash' literals are non-standard: %s\n", text);
+ hsperror(errbuf);
+ }
+
+ if (length > 1) {
+ fprintf(stderr, "\"%s\", line %d, column %d: Unboxed character literal '",
+ input_filename, hsplineno, hspcolno + 1);
+ format_string(stderr, (unsigned char *) text, length);
+ fputs("' too long\n", stderr);
+ hsperror("");
+ }
+ yylval.uhstring = installHstring(1, text);
+ hspcolno = hsmlcolno;
+ POP_STATE;
+ RETURN(CHARPRIM);
+ }
+<Char>({CHAR}|"\"")*' {
+ unsigned length;
+ char *text;
+
+ addtext(yytext, yyleng - 1);
+ text = fetchtext(&length);
+
+ if (length > 1) {
+ fprintf(stderr, "\"%s\", line %d, column %d: Character literal '",
+ input_filename, hsplineno, hspcolno + 1);
+ format_string(stderr, (unsigned char *) text, length);
+ fputs("' too long\n", stderr);
+ hsperror("");
+ }
+ yylval.uhstring = installHstring(1, text);
+ hspcolno = hsmlcolno;
+ POP_STATE;
+ RETURN(CHAR);
+ }
+<Char>({CHAR}|"\"")+ { addtext(yytext, yyleng); }
+
+
+%{
+ /*
+ * String literals. The first form is the quick form, for string literals
+ * that don't contain backslashes. Literals with backslashes are lexed
+ * through multiple rules. First, we match the open " and as many normal
+ * characters as possible. This puts us into the <String> state, where
+ * a backslash is legal. Then, we match the backslash and move into the
+ * <StringEsc> state. When we drop out of <StringEsc>, we collect more normal
+ * characters, moving back and forth between <String> and <StringEsc> as more
+ * backslashes are encountered. (We may even digress into <Comment> mode if we
+ * find a comment in a gap between backslashes.) Finally, we read the last chunk
+ * of normal characters and the close ".
+ */
+%}
+
+<GlaExt,GhcPragma>"\""({CHAR}|"'")*"\""# {
+ yylval.uhstring = installHstring(yyleng-3, yytext+1);
+ /* the -3 accounts for the " on front, "# on the end */
+ RETURN(STRINGPRIM);
+ }
+<Code,GlaExt,GhcPragma>"\""({CHAR}|"'")*"\"" {
+ yylval.uhstring = installHstring(yyleng-2, yytext+1);
+ RETURN(STRING);
+ }
+<Code,GlaExt,GhcPragma>"\""({CHAR}|"'")* {
+ hsmlcolno = hspcolno;
+ cleartext();
+ addtext(yytext+1, yyleng-1);
+ PUSH_STATE(String);
+ }
+<String>({CHAR}|"'")*"\"#" {
+ unsigned length;
+ char *text;
+
+ addtext(yytext, yyleng-2);
+ text = fetchtext(&length);
+
+ if (! (nonstandardFlag || in_interface)) {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf, "`String-hash' literals are non-standard: %s\n", text);
+ hsperror(errbuf);
+ }
+
+ yylval.uhstring = installHstring(length, text);
+ hspcolno = hsmlcolno;
+ POP_STATE;
+ RETURN(STRINGPRIM);
+ }
+<String>({CHAR}|"'")*"\"" {
+ unsigned length;
+ char *text;
+
+ addtext(yytext, yyleng-1);
+ text = fetchtext(&length);
+
+ yylval.uhstring = installHstring(length, text);
+ hspcolno = hsmlcolno;
+ POP_STATE;
+ RETURN(STRING);
+ }
+<String>({CHAR}|"'")+ { addtext(yytext, yyleng); }
+
+%{
+ /*
+ * Character and string escapes are roughly the same, but strings have the
+ * extra `\&' sequence which is not allowed for characters. Also, comments
+ * are allowed in the <StringEsc> state. (See the comment section much
+ * further down.)
+ *
+ * NB: Backslashes and tabs are stored in strings as themselves.
+ * But if we print them (in printtree.c), they must go out as
+ * "\\\\" and "\\t" respectively. (This is because of the bogus
+ * intermediate format that the parser produces. It uses '\t' fpr end of
+ * string, so it needs to be able to escape tabs, which means that it
+ * also needs to be able to escape the escape character ('\\'). Sigh.
+ */
+%}
+
+<Char>\\ { PUSH_STATE(CharEsc); }
+<String>\\& /* Ignore */ ;
+<String>\\ { PUSH_STATE(StringEsc); noGap = TRUE; }
+
+<CharEsc>\\ { addchar(*yytext); POP_STATE; }
+<StringEsc>\\ { if (noGap) { addchar(*yytext); } POP_STATE; }
+
+<CharEsc,StringEsc>["'] { addchar(*yytext); POP_STATE; }
+<CharEsc,StringEsc>NUL { addchar('\000'); POP_STATE; }
+<CharEsc,StringEsc>SOH { addchar('\001'); POP_STATE; }
+<CharEsc,StringEsc>STX { addchar('\002'); POP_STATE; }
+<CharEsc,StringEsc>ETX { addchar('\003'); POP_STATE; }
+<CharEsc,StringEsc>EOT { addchar('\004'); POP_STATE; }
+<CharEsc,StringEsc>ENQ { addchar('\005'); POP_STATE; }
+<CharEsc,StringEsc>ACK { addchar('\006'); POP_STATE; }
+<CharEsc,StringEsc>BEL |
+<CharEsc,StringEsc>a { addchar('\007'); POP_STATE; }
+<CharEsc,StringEsc>BS |
+<CharEsc,StringEsc>b { addchar('\010'); POP_STATE; }
+<CharEsc,StringEsc>HT |
+<CharEsc,StringEsc>t { addchar('\011'); POP_STATE; }
+<CharEsc,StringEsc>LF |
+<CharEsc,StringEsc>n { addchar('\012'); POP_STATE; }
+<CharEsc,StringEsc>VT |
+<CharEsc,StringEsc>v { addchar('\013'); POP_STATE; }
+<CharEsc,StringEsc>FF |
+<CharEsc,StringEsc>f { addchar('\014'); POP_STATE; }
+<CharEsc,StringEsc>CR |
+<CharEsc,StringEsc>r { addchar('\015'); POP_STATE; }
+<CharEsc,StringEsc>SO { addchar('\016'); POP_STATE; }
+<CharEsc,StringEsc>SI { addchar('\017'); POP_STATE; }
+<CharEsc,StringEsc>DLE { addchar('\020'); POP_STATE; }
+<CharEsc,StringEsc>DC1 { addchar('\021'); POP_STATE; }
+<CharEsc,StringEsc>DC2 { addchar('\022'); POP_STATE; }
+<CharEsc,StringEsc>DC3 { addchar('\023'); POP_STATE; }
+<CharEsc,StringEsc>DC4 { addchar('\024'); POP_STATE; }
+<CharEsc,StringEsc>NAK { addchar('\025'); POP_STATE; }
+<CharEsc,StringEsc>SYN { addchar('\026'); POP_STATE; }
+<CharEsc,StringEsc>ETB { addchar('\027'); POP_STATE; }
+<CharEsc,StringEsc>CAN { addchar('\030'); POP_STATE; }
+<CharEsc,StringEsc>EM { addchar('\031'); POP_STATE; }
+<CharEsc,StringEsc>SUB { addchar('\032'); POP_STATE; }
+<CharEsc,StringEsc>ESC { addchar('\033'); POP_STATE; }
+<CharEsc,StringEsc>FS { addchar('\034'); POP_STATE; }
+<CharEsc,StringEsc>GS { addchar('\035'); POP_STATE; }
+<CharEsc,StringEsc>RS { addchar('\036'); POP_STATE; }
+<CharEsc,StringEsc>US { addchar('\037'); POP_STATE; }
+<CharEsc,StringEsc>SP { addchar('\040'); POP_STATE; }
+<CharEsc,StringEsc>DEL { addchar('\177'); POP_STATE; }
+<CharEsc,StringEsc>"^"{CNTRL} { char c = yytext[1] - '@'; addchar(c); POP_STATE; }
+<CharEsc,StringEsc>{D}+ {
+ int i = strtol(yytext, NULL, 10);
+ if (i < NCHARS) {
+ addchar((char) i);
+ } else {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
+ yytext);
+ hsperror(errbuf);
+ }
+ POP_STATE;
+ }
+<CharEsc,StringEsc>o{O}+ {
+ int i = strtol(yytext + 1, NULL, 8);
+ if (i < NCHARS) {
+ addchar((char) i);
+ } else {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
+ yytext);
+ hsperror(errbuf);
+ }
+ POP_STATE;
+ }
+<CharEsc,StringEsc>x{H}+ {
+ int i = strtol(yytext + 1, NULL, 16);
+ if (i < NCHARS) {
+ addchar((char) i);
+ } else {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
+ yytext);
+ hsperror(errbuf);
+ }
+ POP_STATE;
+ }
+
+%{
+ /*
+ * Simple comments and whitespace. Normally, we would just ignore these, but
+ * in case we're processing a string escape, we need to note that we've seen
+ * a gap.
+ *
+ * Note that we cater for a comment line that *doesn't* end in a newline.
+ * This is incorrect, strictly speaking, but seems like the right thing
+ * to do. Reported by Rajiv Mirani. (WDP 95/08)
+ */
+%}
+
+<Code,GlaExt,StringEsc>"--".*{NL}?{WS}* |
+<Code,GlaExt,GhcPragma,UserPragma,StringEsc>{WS}+ { noGap = FALSE; }
+
+%{
+ /*
+ * Nested comments. The major complication here is in trying to match the
+ * longest lexemes possible, for better performance. (See the flex document.)
+ * That's why the rules look so bizarre.
+ */
+%}
+
+<Code,GlaExt,GhcPragma,UserPragma,StringEsc>"{-" {
+ noGap = FALSE; nested_comments = 1; PUSH_STATE(Comment);
+ }
+
+<Comment>[^-{]* |
+<Comment>"-"+[^-{}]+ |
+<Comment>"{"+[^-{}]+ ;
+<Comment>"{-" { nested_comments++; }
+<Comment>"-}" { if (--nested_comments == 0) POP_STATE; }
+<Comment>(.|\n) ;
+
+%{
+ /*
+ * Illegal characters. This used to be a single rule, but we might as well
+ * pass on as much information as we have, so now we indicate our state in
+ * the error message.
+ */
+%}
+
+<INITIAL,Code,GlaExt,GhcPragma,UserPragma>(.|\n) {
+ fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
+ input_filename, hsplineno, hspcolno + 1);
+ format_string(stderr, (unsigned char *) yytext, 1);
+ fputs("'\n", stderr);
+ hsperror("");
+ }
+<Char>(.|\n) {
+ fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
+ input_filename, hsplineno, hspcolno + 1);
+ format_string(stderr, (unsigned char *) yytext, 1);
+ fputs("' in a character literal\n", stderr);
+ hsperror("");
+ }
+<CharEsc>(.|\n) {
+ fprintf(stderr, "\"%s\", line %d, column %d: Illegal character escape: `\\",
+ input_filename, hsplineno, hspcolno + 1);
+ format_string(stderr, (unsigned char *) yytext, 1);
+ fputs("'\n", stderr);
+ hsperror("");
+ }
+<String>(.|\n) { if (nonstandardFlag) {
+ addtext(yytext, yyleng);
+ } else {
+ fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
+ input_filename, hsplineno, hspcolno + 1);
+ format_string(stderr, (unsigned char *) yytext, 1);
+ fputs("' in a string literal\n", stderr);
+ hsperror("");
+ }
+ }
+<StringEsc>(.|\n) {
+ if (noGap) {
+ fprintf(stderr, "\"%s\", line %d, column %d: Illegal string escape: `\\",
+ input_filename, hsplineno, hspcolno + 1);
+ format_string(stderr, (unsigned char *) yytext, 1);
+ fputs("'\n", stderr);
+ hsperror("");
+ } else {
+ fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
+ input_filename, hsplineno, hspcolno + 1);
+ format_string(stderr, (unsigned char *) yytext, 1);
+ fputs("' in a string gap\n", stderr);
+ hsperror("");
+ }
+ }
+
+%{
+ /*
+ * End of file. In any sub-state, this is an error. However, for the primary
+ * <Code> and <GlaExt> states, this is perfectly normal. We just return an EOF
+ * and let the yylex() wrapper deal with whatever has to be done next (e.g.
+ * adding virtual close curlies, or closing an interface and returning to the
+ * primary source file.
+ *
+ * Note that flex does not call YY_USER_ACTION for <<EOF>> rules. Hence the
+ * line/column advancement has to be done by hand.
+ */
+%}
+
+<Char,CharEsc><<EOF>> {
+ hsplineno = hslineno; hspcolno = hscolno;
+ hsperror("unterminated character literal");
+ }
+<Comment><<EOF>> {
+ hsplineno = hslineno; hspcolno = hscolno;
+ hsperror("unterminated comment");
+ }
+<String,StringEsc><<EOF>> {
+ hsplineno = hslineno; hspcolno = hscolno;
+ hsperror("unterminated string literal");
+ }
+<GhcPragma><<EOF>> {
+ hsplineno = hslineno; hspcolno = hscolno;
+ hsperror("unterminated interface pragma");
+ }
+<UserPragma><<EOF>> {
+ hsplineno = hslineno; hspcolno = hscolno;
+ hsperror("unterminated user-specified pragma");
+ }
+<Code,GlaExt><<EOF>> { hsplineno = hslineno; hspcolno = hscolno; return(EOF); }
+
+%%
+
+/**********************************************************************
+* *
+* *
+* YACC/LEX Initialisation etc. *
+* *
+* *
+**********************************************************************/
+
+/*
+ We initialise input_filename to "<stdin>".
+ This allows unnamed sources to be piped into the parser.
+*/
+
+extern BOOLEAN acceptPrim;
+
+void
+yyinit(void)
+{
+ input_filename = xstrdup("<stdin>");
+
+ /* We must initialize the input buffer _now_, because we call
+ setyyin _before_ calling yylex for the first time! */
+ yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE));
+
+ if (acceptPrim)
+ PUSH_STATE(GlaExt);
+ else
+ PUSH_STATE(Code);
+}
+
+static void
+new_filename(char *f) /* This looks pretty dodgy to me (WDP) */
+{
+ if (input_filename != NULL)
+ free(input_filename);
+ input_filename = xstrdup(f);
+}
+
+/**********************************************************************
+* *
+* *
+* Layout Processing *
+* *
+* *
+**********************************************************************/
+
+/*
+ The following section deals with Haskell Layout conventions
+ forcing insertion of ; or } as appropriate
+*/
+
+static BOOLEAN
+hsshouldindent(void)
+{
+ return (!forgetindent && INDENTON);
+}
+
+
+/* Enter new context and set new indentation level */
+void
+hssetindent(void)
+{
+#ifdef HSP_DEBUG
+ fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
+#endif
+
+ /*
+ * partain: first chk that new indent won't be less than current one; this code
+ * doesn't make sense to me; hscolno tells the position of the _end_ of the
+ * current token; what that has to do with indenting, I don't know.
+ */
+
+
+ if (hscolno - 1 <= INDENTPT) {
+ if (INDENTPT == -1)
+ return; /* Empty input OK for Haskell 1.1 */
+ else {
+ char errbuf[ERR_BUF_SIZE];
+
+ sprintf(errbuf, "Layout error -- indentation should be > %d cols", INDENTPT);
+ hsperror(errbuf);
+ }
+ }
+ hsentercontext((hspcolno << 1) | 1);
+}
+
+
+/* Enter a new context without changing the indentation level */
+void
+hsincindent(void)
+{
+#ifdef HSP_DEBUG
+ fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
+#endif
+ hsentercontext(indenttab[icontexts] & ~1);
+}
+
+
+/* Turn off indentation processing, usually because an explicit "{" has been seen */
+void
+hsindentoff(void)
+{
+ forgetindent = TRUE;
+}
+
+
+/* Enter a new layout context. */
+static void
+hsentercontext(int indent)
+{
+ /* Enter new context and set indentation as specified */
+ if (++icontexts >= MAX_CONTEXTS) {
+ char errbuf[ERR_BUF_SIZE];
+
+ sprintf(errbuf, "`wheres' and `cases' nested too deeply (>%d)", MAX_CONTEXTS - 1);
+ hsperror(errbuf);
+ }
+ forgetindent = FALSE;
+ indenttab[icontexts] = indent;
+#ifdef HSP_DEBUG
+ fprintf(stderr, "hsentercontext:indent=%d,hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", indent, hscolno, hspcolno, icontexts, INDENTPT);
+#endif
+}
+
+
+/* Exit a layout context */
+void
+hsendindent(void)
+{
+ --icontexts;
+#ifdef HSP_DEBUG
+ fprintf(stderr, "hsendindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
+#endif
+}
+
+/*
+ * Return checks the indentation level and returns ;, } or the specified token.
+ */
+
+static int
+Return(int tok)
+{
+#ifdef HSP_DEBUG
+ extern int yyleng;
+#endif
+
+ if (hsshouldindent()) {
+ if (hspcolno < INDENTPT) {
+#ifdef HSP_DEBUG
+ fprintf(stderr, "inserted '}' before %d (%d:%d:%d:%d)\n", tok, hspcolno, hscolno, yyleng, INDENTPT);
+#endif
+ hssttok = tok;
+ return (VCCURLY);
+ } else if (hspcolno == INDENTPT) {
+#ifdef HSP_DEBUG
+ fprintf(stderr, "inserted ';' before %d (%d:%d)\n", tok, hspcolno, INDENTPT);
+#endif
+ hssttok = -tok;
+ return (SEMI);
+ }
+ }
+ hssttok = -1;
+#ifdef HSP_DEBUG
+ fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT);
+#endif
+ return (tok);
+}
+
+
+/*
+ * Redefine yylex to check for stacked tokens, yylex1() is the original yylex()
+ */
+int
+yylex()
+{
+ int tok;
+ static BOOLEAN eof = FALSE;
+
+ if (!eof) {
+ if (hssttok != -1) {
+ if (hssttok < 0) {
+ tok = -hssttok;
+ hssttok = -1;
+ return tok;
+ }
+ RETURN(hssttok);
+ } else {
+ endlineno = hslineno;
+ if ((tok = yylex1()) != EOF)
+ return tok;
+ else
+ eof = TRUE;
+ }
+ }
+ if (icontexts > icontexts_save) {
+ if (INDENTON) {
+ eof = TRUE;
+ indenttab[icontexts] = 0;
+ return (VCCURLY);
+ } else
+ hsperror("missing '}' at end of file");
+ } else if (hsbuf_save != NULL) {
+ fclose(yyin);
+ yy_delete_buffer(YY_CURRENT_BUFFER);
+ yy_switch_to_buffer(hsbuf_save);
+ hsbuf_save = NULL;
+ new_filename(filename_save);
+ free(filename_save);
+ hslineno = hslineno_save;
+ hsplineno = hsplineno_save;
+ hscolno = hscolno_save;
+ hspcolno = hspcolno_save;
+ etags = etags_save;
+ in_interface = FALSE;
+ icontexts = icontexts_save - 1;
+ icontexts_save = 0;
+#ifdef HSP_DEBUG
+ fprintf(stderr, "finished reading interface (%d:%d:%d)\n", hscolno, hspcolno, INDENTPT);
+#endif
+ eof = FALSE;
+ RETURN(LEOF);
+ } else {
+ yyterminate();
+ }
+ abort(); /* should never get here! */
+ return(0);
+}
+
+/**********************************************************************
+* *
+* *
+* Input Processing for Interfaces *
+* *
+* *
+**********************************************************************/
+
+/* setyyin(file) open file as new lex input buffer */
+extern FILE *yyin;
+
+void
+setyyin(char *file)
+{
+ hsbuf_save = YY_CURRENT_BUFFER;
+ if ((yyin = fopen(file, "r")) == NULL) {
+ char errbuf[ERR_BUF_SIZE];
+
+ sprintf(errbuf, "can't read \"%-.50s\"", file);
+ hsperror(errbuf);
+ }
+ yy_switch_to_buffer(yy_create_buffer(yyin, YY_BUF_SIZE));
+
+ hslineno_save = hslineno;
+ hsplineno_save = hsplineno;
+ hslineno = hsplineno = 1;
+
+ filename_save = input_filename;
+ input_filename = NULL;
+ new_filename(file);
+ hscolno_save = hscolno;
+ hspcolno_save = hspcolno;
+ hscolno = hspcolno = 0;
+ in_interface = TRUE;
+ etags_save = etags; /* do not do "etags" stuff in interfaces */
+ etags = 0; /* We remember whether we are doing it in
+ the module, so we can restore it later [WDP 94/09] */
+ hsentercontext(-1); /* partain: changed this from 0 */
+ icontexts_save = icontexts;
+#ifdef HSP_DEBUG
+ fprintf(stderr, "reading %s (%d:%d:%d)\n", input_filename, hscolno_save, hspcolno_save, INDENTPT);
+#endif
+}
+
+static void
+layout_input(char *text, int len)
+{
+#ifdef HSP_DEBUG
+ fprintf(stderr, "Scanning \"%s\"\n", text);
+#endif
+
+ hsplineno = hslineno;
+ hspcolno = hscolno;
+
+ while (len-- > 0) {
+ switch (*text++) {
+ case '\n':
+ case '\r':
+ case '\f':
+ hslineno++;
+ hscolno = 0;
+ break;
+ case '\t':
+ hscolno += 8 - (hscolno % 8); /* Tabs stops are 8 columns apart */
+ break;
+ case '\v':
+ break;
+ default:
+ ++hscolno;
+ break;
+ }
+ }
+}
+
+void
+setstartlineno(void)
+{
+ startlineno = hsplineno;
+
+ if (modulelineno == 0) {
+ modulelineno = startlineno;
+ }
+
+#if 1/*etags*/
+#else
+ if (etags)
+ fprintf(stderr,"%u\tsetstartlineno (col %u)\n",startlineno,hscolno);
+#endif
+}
+
+/**********************************************************************
+* *
+* *
+* Text Caching *
+* *
+* *
+**********************************************************************/
+
+#define CACHE_SIZE YY_BUF_SIZE
+
+static struct {
+ unsigned allocated;
+ unsigned next;
+ char *text;
+} textcache = { 0, 0, NULL };
+
+static void
+cleartext(void)
+{
+/* fprintf(stderr, "cleartext\n"); */
+ textcache.next = 0;
+ if (textcache.allocated == 0) {
+ textcache.allocated = CACHE_SIZE;
+ textcache.text = xmalloc(CACHE_SIZE);
+ }
+}
+
+static void
+addtext(char *text, unsigned length)
+{
+/* fprintf(stderr, "addtext: %d %s\n", length, text); */
+
+ if (length == 0)
+ return;
+
+ if (textcache.next + length + 1 >= textcache.allocated) {
+ textcache.allocated += length + CACHE_SIZE;
+ textcache.text = xrealloc(textcache.text, textcache.allocated);
+ }
+ bcopy(text, textcache.text + textcache.next, length);
+ textcache.next += length;
+}
+
+static void
+addchar(char c)
+{
+/* fprintf(stderr, "addchar: %c\n", c); */
+
+ if (textcache.next + 2 >= textcache.allocated) {
+ textcache.allocated += CACHE_SIZE;
+ textcache.text = xrealloc(textcache.text, textcache.allocated);
+ }
+ textcache.text[textcache.next++] = c;
+}
+
+static char *
+fetchtext(unsigned *length)
+{
+/* fprintf(stderr, "fetchtext: %d\n", textcache.next); */
+
+ *length = textcache.next;
+ textcache.text[textcache.next] = '\0';
+ return textcache.text;
+}
+
+/**********************************************************************
+* *
+* *
+* Identifier Processing *
+* *
+* *
+**********************************************************************/
+
+/*
+ hsnewid Enters an id of length n into the symbol table.
+*/
+
+static void
+hsnewid(char *name, int length)
+{
+ char save = name[length];
+
+ name[length] = '\0';
+ yylval.uid = installid(name);
+ name[length] = save;
+}
+
+BOOLEAN
+hsnewqid(char *name, int length)
+{
+ char* dot;
+ char save = name[length];
+ name[length] = '\0';
+
+ dot = strchr(name, '.');
+ *dot = '\0';
+ yylval.uqid = mkaqual(installid(name),installid(dot+1));
+ *dot = '.';
+ name[length] = save;
+
+ return _isconstr(dot+1);
+}
+
+BOOLEAN
+isconstr(char *s) /* walks past leading underscores before using the macro */
+{
+ char *temp = s;
+
+ for ( ; temp != NULL && *temp == '_' ; temp++ );
+
+ return _isconstr(temp);
+}
--- /dev/null
+/**************************************************************************
+* File: hsparser.y *
+* *
+* Author: Maria M. Gutierrez *
+* Modified by: Kevin Hammond *
+* Last date revised: December 13 1991. KH. *
+* Modification: Haskell 1.1 Syntax. *
+* *
+* *
+* Description: This file contains the LALR(1) grammar for Haskell. *
+* *
+* Entry Point: module *
+* *
+* Problems: None known. *
+* *
+* *
+* LALR(1) Syntax for Haskell 1.2 *
+* *
+**************************************************************************/
+
+
+%{
+#ifdef HSP_DEBUG
+# define YYDEBUG 1
+#endif
+
+#include <stdio.h>
+#include <ctype.h>
+#include <string.h>
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+/**********************************************************************
+* *
+* *
+* Imported Variables and Functions *
+* *
+* *
+**********************************************************************/
+
+static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
+
+extern BOOLEAN nonstandardFlag;
+extern BOOLEAN etags;
+
+extern VOID find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
+
+extern char *input_filename;
+static char *the_module_name;
+static char *iface_name;
+static char iface_filename[FILENAME_SIZE];
+
+static maybe module_exports; /* Exported entities */
+static list prelude_core_import, prelude_imports;
+ /* Entities imported from the Prelude */
+
+extern tree niltree;
+extern list Lnil;
+
+extern tree root;
+
+/* For FN, PREVPATT and SAMEFN macros */
+extern qid fns[];
+extern BOOLEAN samefn[];
+extern tree prevpatt[];
+extern short icontexts;
+
+/* Line Numbers */
+extern int hsplineno, hspcolno;
+extern int modulelineno;
+extern int startlineno;
+extern int endlineno;
+
+/**********************************************************************
+* *
+* *
+* Fixity and Precedence Declarations *
+* *
+* *
+**********************************************************************/
+
+/* OLD 95/08: list fixlist; */
+static int Fixity = 0, Precedence = 0;
+struct infix;
+
+char *ineg PROTO((char *));
+
+int importlineno = 0; /* The line number where an import starts */
+
+long inimport; /* Info about current import */
+id importmod;
+long importas;
+id asmod;
+long importqual;
+long importspec;
+long importhide;
+list importlist;
+
+extern BOOLEAN inpat; /* True when parsing a pattern */
+extern BOOLEAN implicitPrelude; /* True when we should read the Prelude if not given */
+extern BOOLEAN haskell1_2Flag; /* True if we are attempting (proto)Haskell 1.3 */
+
+extern int thisIfacePragmaVersion;
+%}
+
+%union {
+ tree utree;
+ list ulist;
+ ttype uttype;
+ constr uconstr;
+ binding ubinding;
+ pbinding upbinding;
+ entidt uentid;
+ id uid;
+ qid uqid;
+ literal uliteral;
+ maybe umaybe;
+ either ueither;
+ long ulong;
+ float ufloat;
+ char *ustring;
+ hstring uhstring;
+ hpragma uhpragma;
+ coresyn ucoresyn;
+}
+
+
+/**********************************************************************
+* *
+* *
+* These are lexemes. *
+* *
+* *
+**********************************************************************/
+
+
+%token VARID CONID QVARID QCONID
+ VARSYM CONSYM QVARSYM QCONSYM
+
+%token INTEGER FLOAT CHAR STRING
+ CHARPRIM STRINGPRIM INTPRIM FLOATPRIM
+ DOUBLEPRIM CLITLIT
+
+
+
+/**********************************************************************
+* *
+* *
+* Special Symbols *
+* *
+* *
+**********************************************************************/
+
+%token OCURLY CCURLY VCCURLY SEMI
+%token OBRACK CBRACK OPAREN CPAREN
+%token COMMA BQUOTE
+
+
+/**********************************************************************
+* *
+* *
+* Reserved Operators *
+* *
+* *
+**********************************************************************/
+
+%token DOTDOT DCOLON EQUAL
+%token LAMBDA VBAR RARROW
+%token LARROW MINUS
+
+
+/**********************************************************************
+* *
+* *
+* Reserved Identifiers *
+* *
+* *
+**********************************************************************/
+
+%token CASE CLASS DATA
+%token DEFAULT DERIVING DO
+%token ELSE IF IMPORT
+%token IN INFIX INFIXL
+%token INFIXR INSTANCE LET
+%token MODULE NEWTYPE OF
+%token THEN TYPE WHERE
+
+%token INTERFACE SCC
+%token CCALL CCALL_GC CASM CASM_GC
+
+
+/**********************************************************************
+* *
+* *
+* Valid symbols/identifiers which need to be recognised *
+* *
+* *
+**********************************************************************/
+
+%token WILDCARD AT LAZY BANG
+%token AS HIDING QUALIFIED
+
+
+/**********************************************************************
+* *
+* *
+* Special Symbols for the Lexer *
+* *
+* *
+**********************************************************************/
+
+%token LEOF
+%token GHC_PRAGMA END_PRAGMA NO_PRAGMA NOINFO_PRAGMA SPECIALISE_PRAGMA
+%token ARITY_PRAGMA UPDATE_PRAGMA STRICTNESS_PRAGMA KIND_PRAGMA
+%token UNFOLDING_PRAGMA MAGIC_UNFOLDING_PRAGMA DEFOREST_PRAGMA
+%token SPECIALISE_UPRAGMA INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
+%token DEFOREST_UPRAGMA END_UPRAGMA
+%token TYLAMBDA COCON COPRIM COAPP COTYAPP FORALL TYVAR_TEMPLATE_ID
+%token CO_ALG_ALTS CO_PRIM_ALTS CO_NO_DEFAULT CO_LETREC
+%token CO_SDSEL_ID CO_METH_ID CO_DEFM_ID CO_DFUN_ID CO_CONSTM_ID
+%token CO_SPEC_ID CO_WRKR_ID CO_ORIG_NM
+%token UNFOLD_ALWAYS UNFOLD_IF_ARGS
+%token NOREP_INTEGER NOREP_RATIONAL NOREP_STRING
+%token CO_PRELUDE_DICTS_CC CO_ALL_DICTS_CC CO_USER_CC CO_AUTO_CC CO_DICT_CC
+%token CO_CAF_CC CO_DUPD_CC
+
+/**********************************************************************
+* *
+* *
+* Precedences of the various tokens *
+* *
+* *
+**********************************************************************/
+
+
+%left CASE LET IN
+ IF ELSE LAMBDA
+ SCC CASM CCALL CASM_GC CCALL_GC
+
+%left VARSYM CONSYM QVARSYM QCONSYM
+ MINUS BQUOTE BANG DARROW
+
+%left DCOLON
+
+%left SEMI COMMA
+
+%left OCURLY OBRACK OPAREN
+
+%left EQUAL
+
+%right RARROW
+
+/**********************************************************************
+* *
+* *
+* Type Declarations *
+* *
+* *
+**********************************************************************/
+
+
+%type <ulist> caserest alts alt quals
+ dorest stmts stmt
+ rbinds rpats list_exps
+ qvarsk qvars_list
+ constrs constr1 fields
+ types atypes batypes
+ types_and_maybe_ids
+ pats context context_list tyvar_list
+ export_list enames
+ import_list inames
+ impdecls maybeimpdecls impdecl
+ maybefixes fixes fix ops
+ dtyclses dtycls_list
+ gdrhs gdpat valrhs
+ lampats cexps
+ idata_pragma_specs idata_pragma_specslist
+ gen_pragma_list type_pragma_pairs
+ type_pragma_pairs_maybe name_pragma_pairs
+ type_maybes
+ core_binders core_tyvars core_tv_templates
+ core_types core_type_list
+ core_atoms core_atom_list
+ core_alg_alts core_prim_alts corec_binds
+ core_type_maybes
+
+%type <umaybe> maybeexports impas maybeimpspec
+ type_maybe core_type_maybe
+
+
+%type <ueither> impspec
+
+%type <uliteral> lit_constant
+
+%type <utree> exp oexp dexp kexp fexp aexp rbind texps
+ expL oexpL kexpL expLno oexpLno dexpLno kexpLno
+ qual gd leftexp
+ apat bpat pat apatc conpat dpat fpat opat aapat
+ dpatk fpatk opatk aapatk rpat
+
+
+%type <uid> MINUS DARROW AS LAZY
+ VARID CONID VARSYM CONSYM
+ TYVAR_TEMPLATE_ID
+ var con varop conop op
+ vark varid varsym varsym_nominus
+ tycon modid impmod ccallid
+
+%type <uqid> QVARID QCONID QVARSYM QCONSYM
+ qvarid qconid qvarsym qconsym
+ qvar qcon qvarop qconop qop
+ qvark qconk qtycon qtycls
+ gcon gconk gtycon qop1 qvarop1
+ ename iname
+
+%type <ubinding> topdecl topdecls letdecls
+ typed datad newtd classd instd defaultd
+ decl decls valdef instdef instdefs
+ maybeifixes iimport iimports maybeiimports
+ ityped idatad inewtd iclassd iinstd ivarsd
+ itopdecl itopdecls
+ maybe_where
+ interface dointerface readinterface ibody
+ cbody rinst
+ type_and_maybe_id
+
+%type <upbinding> valrhs1 altrest
+
+%type <uttype> simple ctype type atype btype
+ gtyconapp ntyconapp ntycon gtyconvars
+ bbtype batype btyconapp
+ class restrict_inst general_inst tyvar
+ core_type
+
+%type <uconstr> constr field
+
+%type <ustring> FLOAT INTEGER INTPRIM
+ FLOATPRIM DOUBLEPRIM CLITLIT
+
+%type <uhstring> STRING STRINGPRIM CHAR CHARPRIM
+
+%type <uentid> export import
+
+%type <uhpragma> idata_pragma inewt_pragma idata_pragma_spectypes
+ iclas_pragma iclasop_pragma
+ iinst_pragma gen_pragma ival_pragma arity_pragma
+ update_pragma strictness_pragma worker_info
+ deforest_pragma
+ unfolding_pragma unfolding_guidance type_pragma_pair
+ name_pragma_pair
+
+%type <ucoresyn> core_expr core_case_alts core_id core_binder core_atom
+ core_alg_alt core_prim_alt core_default corec_bind
+ co_primop co_scc co_caf co_dupd
+
+%type <ulong> commas impqual
+
+/**********************************************************************
+* *
+* *
+* Start Symbol for the Parser *
+* *
+* *
+**********************************************************************/
+
+%start pmodule
+
+
+%%
+
+pmodule : {
+ inimport = 1;
+ importmod = install_literal("Prelude");
+ importas = 0;
+ asmod = NULL;
+ importqual = 0;
+ importspec = 0;
+ importhide = 0;
+ importlist = Lnil;
+ }
+ readpreludecore readprelude
+ {
+ inimport = 0;
+ importmod = NULL;
+
+ modulelineno = 0;
+ }
+ module
+ ;
+
+module : modulekey modid maybeexports
+ {
+ the_module_name = $2;
+ module_exports = $3;
+ }
+ WHERE body
+ | {
+ the_module_name = install_literal("Main");
+ module_exports = mknothing();
+ }
+ body
+ ;
+
+body : ocurly { setstartlineno(); } orestm
+ | vocurly vrestm
+ ;
+
+orestm : maybeimpdecls maybefixes topdecls ccurly
+ {
+ root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,$2,$3,modulelineno);
+ }
+ | impdecls ccurly
+ {
+ root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,Lnil,mknullbind(),modulelineno);
+ }
+
+vrestm : maybeimpdecls maybefixes topdecls vccurly
+ {
+ root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,$2,$3,modulelineno);
+ }
+ | impdecls vccurly
+ {
+ root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,Lnil,mknullbind(),modulelineno);
+ }
+
+
+maybeexports : /* empty */ { $$ = mknothing(); }
+ | OPAREN export_list CPAREN { $$ = mkjust($2); }
+ | OPAREN export_list COMMA CPAREN { $$ = mkjust($2); }
+ ;
+
+export_list:
+ export { $$ = lsing($1); }
+ | export_list COMMA export { $$ = lapp($1, $3); }
+ ;
+
+export : qvar { $$ = mkentid($1); }
+ | gtycon { $$ = mkenttype($1); }
+ | gtycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
+ | gtycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil); }
+ | gtycon OPAREN enames CPAREN { $$ = mkenttypenamed($1,$3); }
+ | MODULE modid { $$ = mkentmod($2); }
+ ;
+
+enames : ename { $$ = lsing($1); }
+ | enames COMMA ename { $$ = lapp($1,$3); }
+ ;
+ename : qvar
+ | qcon
+ ;
+
+
+maybeimpdecls : /* empty */ { $$ = Lnil; }
+ | impdecls SEMI { $$ = $1; }
+ ;
+
+impdecls: impdecl { $$ = $1; }
+ | impdecls SEMI impdecl { $$ = lconc($1,$3); }
+ ;
+
+
+impdecl : importkey
+ {
+ inimport = 1;
+ importlineno = startlineno;
+ }
+ impqual impmod dointerface impas maybeimpspec
+ {
+ $$ = lsing(mkimport(iface_name,xstrdup(iface_filename),$5,
+ $4,$3,$6,$7,importlineno));
+ inimport = 0;
+ importmod = NULL;
+ importas = 0;
+ asmod = NULL;
+ importqual = 0;
+ importspec = 0;
+ importhide = 0;
+ importlist = Lnil;
+ }
+ ;
+
+impmod : modid { $$ = importmod = $1; }
+ ;
+
+impqual : /* noqual */ { $$ = importqual = 0; }
+ | QUALIFIED { $$ = importqual = 1; }
+ ;
+
+impas : /* noas */ { $$ = mknothing(); importas = 0; asmod = NULL; }
+ | AS modid { $$ = mkjust($2); importas = 1; asmod = $2; }
+ ;
+
+maybeimpspec : /* empty */ { $$ = mknothing(); importspec = 0; }
+ | impspec { $$ = mkjust($1); importspec = 1; }
+ ;
+
+impspec : OPAREN CPAREN { $$ = mkleft(Lnil); importhide = 0; importlist = Lnil; }
+ | OPAREN import_list CPAREN { $$ = mkleft($2); importhide = 0; importlist = $2; }
+ | OPAREN import_list COMMA CPAREN { $$ = mkleft($2); importhide = 0; importlist = $2; }
+ | HIDING OPAREN import_list CPAREN { $$ = mkright($3); importhide = 1; importlist = $3; }
+ | HIDING OPAREN import_list COMMA CPAREN { $$ = mkright($3); importhide = 1; importlist = $3; }
+ ;
+
+import_list:
+ import { $$ = lsing($1); }
+ | import_list COMMA import { $$ = lapp($1, $3); }
+ ;
+
+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); }
+ ;
+
+inames : iname { $$ = lsing($1); }
+ | inames COMMA iname { $$ = lapp($1,$3); }
+ ;
+iname : var { $$ = mknoqual($1); }
+ | con { $$ = mknoqual($1); }
+ ;
+
+
+/**********************************************************************
+* *
+* *
+* Reading interface files *
+* *
+* *
+**********************************************************************/
+
+dointerface : { /* filename returned in "iface_filename" */
+ char *module_name = id_to_string(importmod);
+ if ( ! etags ) {
+ find_module_on_imports_dirlist(
+ (haskell1_2Flag && strcmp(module_name, "Prelude") == 0)
+ ? "Prel12" : module_name,
+ FALSE, iface_filename);
+ } else {
+ find_module_on_imports_dirlist("PreludeNull_",TRUE,iface_filename);
+ }
+ if (strcmp(module_name,"PreludeCore")==0) {
+ hsperror("Cannot explicitly import `PreludeCore'");
+
+ } else if (strcmp(module_name,"Prelude")==0) {
+ prelude_imports = prelude_core_import; /* unavoidable */
+ }
+ thisIfacePragmaVersion = 0;
+ setyyin(iface_filename);
+ }
+ readinterface
+ { $$ = $2; }
+ ;
+
+readpreludecore:{
+ if ( implicitPrelude && !etags ) {
+ /* we try to avoid reading interfaces when etagging */
+ find_module_on_imports_dirlist(
+ (haskell1_2Flag) ? "PrelCore12" : "PreludeCore",
+ TRUE,iface_filename);
+ } else {
+ find_module_on_imports_dirlist("PreludeNull_",TRUE,iface_filename);
+ }
+ thisIfacePragmaVersion = 0;
+ setyyin(iface_filename);
+ }
+ readinterface
+ {
+ binding prelude_core = mkimport(iface_name,xstrdup(iface_filename),$2,
+ install_literal("PreludeCore"),
+ 0,mknothing(),mknothing(),0);
+ prelude_core_import = (! implicitPrelude) ? Lnil : lsing(prelude_core);
+ }
+ ;
+
+readprelude : {
+ if ( implicitPrelude && !etags ) {
+ find_module_on_imports_dirlist(
+ ( haskell1_2Flag ) ? "Prel12" : "Prelude",
+ TRUE,iface_filename);
+ } else {
+ find_module_on_imports_dirlist("PreludeNull_",TRUE,iface_filename);
+ }
+ thisIfacePragmaVersion = 0;
+ setyyin(iface_filename);
+ }
+ readinterface
+ {
+ binding prelude = mkimport(iface_name,xstrdup(iface_filename),$2,
+ install_literal("Prelude"),
+ 0,mknothing(),mknothing(),0);
+ prelude_imports = (! implicitPrelude) ? Lnil
+ : lconc(prelude_core_import,lsing(prelude));
+ }
+ ;
+
+readinterface:
+ interface LEOF
+ {
+ $$ = $1;
+ }
+ ;
+
+interface:
+ INTERFACE modid
+ {
+ iface_name = $2;
+ }
+ WHERE ibody
+ {
+ $$ = $5;
+ }
+ ;
+
+ibody : ocurly maybeiimports maybeifixes itopdecls ccurly
+ {
+ $$ = mkabind($2,mkabind($3,$4));
+ }
+ | ocurly iimports ccurly
+ {
+ $$ = $2;
+ }
+ | vocurly maybeiimports maybeifixes itopdecls vccurly
+ {
+ $$ = mkabind($2,mkabind($3,$4));
+ }
+ | vocurly iimports vccurly
+ {
+ $$ = $2;
+ }
+ ;
+
+maybeifixes: /* empty */ { $$ = mknullbind(); }
+ | fixes SEMI { $$ = mkmfbind($1); }
+ ;
+
+maybeiimports : /* empty */ { $$ = mknullbind(); }
+ | iimports SEMI { $$ = $1; }
+ ;
+
+iimports : iimport { $$ = $1; }
+ | iimports SEMI iimport { $$ = mkabind($1,$3); }
+ ;
+
+iimport : importkey modid OPAREN import_list CPAREN
+ { $$ = mkmbind($2,$4,startlineno); }
+ ;
+
+
+itopdecls : itopdecl { $$ = $1; }
+ | itopdecls SEMI itopdecl { $$ = mkabind($1,$3); }
+ ;
+
+itopdecl: ityped { $$ = $1; }
+ | idatad { $$ = $1; }
+ | inewtd { $$ = $1; }
+ | iclassd { $$ = $1; }
+ | iinstd { $$ = $1; }
+ | ivarsd { $$ = $1; }
+ | /* empty */ { $$ = mknullbind(); }
+ ;
+
+ivarsd : qvarsk DCOLON ctype ival_pragma
+ { $$ = mksbind($1,$3,startlineno,$4); }
+ ;
+
+ityped : typekey simple EQUAL type
+ { $$ = mknbind($2,$4,startlineno); }
+ ;
+
+idatad : datakey simple idata_pragma
+ { $$ = mktbind(Lnil,$2,Lnil,mknothing(),startlineno,$3); }
+ | datakey simple EQUAL constrs idata_pragma
+ { $$ = mktbind(Lnil,$2,$4,mknothing(),startlineno,$5); }
+ | datakey context DARROW simple idata_pragma
+ { $$ = mktbind($2,$4,Lnil,mknothing(),startlineno,$5); }
+ | datakey context DARROW simple EQUAL constrs idata_pragma
+ { $$ = mktbind($2,$4,$6,mknothing(),startlineno,$7); }
+ ;
+
+inewtd : newtypekey simple inewt_pragma
+ { $$ = mkntbind(Lnil,$2,Lnil,mknothing(),startlineno,$3); }
+ | newtypekey simple EQUAL constr1 inewt_pragma
+ { $$ = mkntbind(Lnil,$2,$4,mknothing(),startlineno,$5); }
+ | newtypekey context DARROW simple inewt_pragma
+ { $$ = mkntbind($2,$4,Lnil,mknothing(),startlineno,$5); }
+ | newtypekey context DARROW simple EQUAL constr1 inewt_pragma
+ { $$ = mkntbind($2,$4,$6,mknothing(),startlineno,$7); }
+ ;
+
+iclassd : classkey context DARROW class iclas_pragma cbody
+ { $$ = mkcbind($2,$4,$6,startlineno,$5); }
+ | classkey class iclas_pragma cbody
+ { $$ = mkcbind(Lnil,$2,$4,startlineno,$3); }
+ ;
+
+iinstd : instkey modid context DARROW gtycon general_inst iinst_pragma
+ { $$ = mkibind(0/*not source*/,$2,$3,$5,$6,mknullbind(),startlineno,$7); }
+ | instkey modid gtycon general_inst iinst_pragma
+ { $$ = mkibind(0/*not source*/,$2,Lnil,$3,$4,mknullbind(),startlineno,$5); }
+ ;
+
+
+/**********************************************************************
+* *
+* *
+* Interface pragma stuff *
+* *
+* *
+**********************************************************************/
+
+idata_pragma:
+ GHC_PRAGMA constrs idata_pragma_specs END_PRAGMA
+ { $$ = mkidata_pragma($2, $3); }
+ | GHC_PRAGMA idata_pragma_specs END_PRAGMA
+ { $$ = mkidata_pragma(Lnil, $2); }
+ | /* empty */ { $$ = mkno_pragma(); }
+ ;
+
+inewt_pragma:
+ GHC_PRAGMA constr1 idata_pragma_specs END_PRAGMA
+ { $$ = mkidata_pragma($2, $3); }
+ | GHC_PRAGMA idata_pragma_specs END_PRAGMA
+ { $$ = mkidata_pragma(Lnil, $2); }
+ | /* empty */ { $$ = mkno_pragma(); }
+ ;
+
+idata_pragma_specs :
+ SPECIALISE_PRAGMA idata_pragma_specslist
+ { $$ = $2; }
+ | /* empty */ { $$ = Lnil; }
+ ;
+
+idata_pragma_specslist:
+ idata_pragma_spectypes { $$ = lsing($1); }
+ | idata_pragma_specslist COMMA idata_pragma_spectypes
+ { $$ = lapp($1, $3); }
+ ;
+
+idata_pragma_spectypes:
+ OBRACK type_maybes CBRACK { $$ = mkidata_pragma_4s($2); }
+ ;
+
+iclas_pragma:
+ GHC_PRAGMA gen_pragma_list END_PRAGMA { $$ = mkiclas_pragma($2); }
+ | /* empty */ { $$ = mkno_pragma(); }
+ ;
+
+iclasop_pragma:
+ GHC_PRAGMA gen_pragma gen_pragma END_PRAGMA
+ { $$ = mkiclasop_pragma($2, $3); }
+ | /* empty */
+ { $$ = mkno_pragma(); }
+ ;
+
+iinst_pragma:
+ GHC_PRAGMA gen_pragma END_PRAGMA
+ { $$ = mkiinst_simpl_pragma($2); }
+
+ | GHC_PRAGMA gen_pragma name_pragma_pairs END_PRAGMA
+ { $$ = mkiinst_const_pragma($2, $3); }
+
+ | /* empty */
+ { $$ = mkno_pragma(); }
+ ;
+
+ival_pragma:
+ GHC_PRAGMA gen_pragma END_PRAGMA
+ { $$ = $2; }
+ | /* empty */
+ { $$ = mkno_pragma(); }
+ ;
+
+gen_pragma:
+ NOINFO_PRAGMA
+ { $$ = mkno_pragma(); }
+ | arity_pragma update_pragma deforest_pragma strictness_pragma unfolding_pragma type_pragma_pairs_maybe
+ { $$ = mkigen_pragma($1, $2, $3, $4, $5, $6); }
+ ;
+
+arity_pragma:
+ NO_PRAGMA { $$ = mkno_pragma(); }
+ | ARITY_PRAGMA INTEGER { $$ = mkiarity_pragma($2); }
+ ;
+
+update_pragma:
+ NO_PRAGMA { $$ = mkno_pragma(); }
+ | UPDATE_PRAGMA INTEGER { $$ = mkiupdate_pragma($2); }
+ ;
+
+deforest_pragma:
+ NO_PRAGMA { $$ = mkno_pragma(); }
+ | DEFOREST_PRAGMA { $$ = mkideforest_pragma(); }
+ ;
+
+strictness_pragma:
+ NO_PRAGMA { $$ = mkno_pragma(); }
+ | STRICTNESS_PRAGMA COCON { $$ = mkistrictness_pragma(installHstring(1, "B"),
+ /* _!_ = COCON = bottom */ mkno_pragma());
+ }
+ | STRICTNESS_PRAGMA STRING worker_info
+ { $$ = mkistrictness_pragma($2, $3); }
+ ;
+
+worker_info:
+ OCURLY gen_pragma CCURLY { $$ = $2; }
+ | /* empty */ { $$ = mkno_pragma(); }
+
+unfolding_pragma:
+ NO_PRAGMA { $$ = mkno_pragma(); }
+ | MAGIC_UNFOLDING_PRAGMA vark
+ { $$ = mkimagic_unfolding_pragma($2); }
+ | UNFOLDING_PRAGMA unfolding_guidance core_expr
+ { $$ = mkiunfolding_pragma($2, $3); }
+ ;
+
+unfolding_guidance:
+ UNFOLD_ALWAYS
+ { $$ = mkiunfold_always(); }
+ | UNFOLD_IF_ARGS INTEGER INTEGER CONID INTEGER
+ { $$ = mkiunfold_if_args($2, $3, $4, $5); }
+ ;
+
+gen_pragma_list:
+ gen_pragma { $$ = lsing($1); }
+ | gen_pragma_list COMMA gen_pragma { $$ = lapp($1, $3); }
+ ;
+
+type_pragma_pairs_maybe:
+ NO_PRAGMA { $$ = Lnil; }
+ | SPECIALISE_PRAGMA type_pragma_pairs { $$ = $2; }
+ ;
+
+/* 1 S/R conflict at COMMA -> shift */
+type_pragma_pairs:
+ type_pragma_pair { $$ = lsing($1); }
+ | type_pragma_pairs COMMA type_pragma_pair { $$ = lapp($1, $3); }
+ ;
+
+type_pragma_pair:
+ OBRACK type_maybes CBRACK INTEGER worker_info
+ { $$ = mkitype_pragma_pr($2, $4, $5); }
+ ;
+
+type_maybes:
+ type_maybe { $$ = lsing($1); }
+ | type_maybes COMMA type_maybe { $$ = lapp($1, $3); }
+ ;
+
+type_maybe:
+ NO_PRAGMA { $$ = mknothing(); }
+ | type { $$ = mkjust($1); }
+ ;
+
+name_pragma_pairs:
+ name_pragma_pair { $$ = lsing($1); }
+ | name_pragma_pairs COMMA name_pragma_pair { $$ = lapp($1, $3); }
+ ;
+
+name_pragma_pair:
+ /* if the gen_pragma concludes with a *comma*-separated SPECs list,
+ we get a parse error --- we have to bracket the gen_pragma
+ */
+
+ var EQUAL OCURLY gen_pragma CCURLY
+ { $$ = mkiname_pragma_pr($1, $4); }
+ ;
+
+/**********************************************************************
+* *
+* *
+* Core syntax stuff *
+* *
+* *
+**********************************************************************/
+
+core_expr:
+ LAMBDA core_binders RARROW core_expr
+ { $$ = mkcolam($2, $4); }
+ | TYLAMBDA core_tyvars RARROW core_expr
+ { $$ = mkcotylam($2, $4); }
+ | COCON con core_types core_atoms
+ { $$ = mkcocon(mkco_id($2), $3, $4); }
+ | COCON CO_ORIG_NM modid con core_types core_atoms
+ { $$ = mkcocon(mkco_orig_id($3,$4), $5, $6); }
+ | COPRIM co_primop core_types core_atoms
+ { $$ = mkcoprim($2, $3, $4); }
+ | COAPP core_expr core_atoms
+ { $$ = mkcoapp($2, $3); }
+ | COTYAPP core_expr OCURLY core_type CCURLY
+ { $$ = mkcotyapp($2, $4); }
+ | CASE core_expr OF OCURLY core_case_alts CCURLY
+ { $$ = mkcocase($2, $5); }
+ | LET OCURLY core_binder EQUAL core_expr CCURLY IN core_expr
+ { $$ = mkcolet(mkcononrec($3, $5), $8); }
+ | CO_LETREC OCURLY corec_binds CCURLY IN core_expr
+ { $$ = mkcolet(mkcorec($3), $6); }
+ | SCC OCURLY co_scc CCURLY core_expr
+ { $$ = mkcoscc($3, $5); }
+ | lit_constant { $$ = mkcoliteral($1); }
+ | core_id { $$ = mkcovar($1); }
+ ;
+
+core_case_alts :
+ CO_ALG_ALTS core_alg_alts core_default
+ { $$ = mkcoalg_alts($2, $3); }
+ | CO_PRIM_ALTS core_prim_alts core_default
+ { $$ = mkcoprim_alts($2, $3); }
+ ;
+
+core_alg_alts :
+ /* empty */ { $$ = Lnil; }
+ | core_alg_alts core_alg_alt { $$ = lapp($1, $2); }
+ ;
+
+core_alg_alt:
+ core_id core_binders RARROW core_expr SEMI { $$ = mkcoalg_alt($1, $2, $4); }
+ /* core_id is really too generous */
+ ;
+
+core_prim_alts :
+ /* empty */ { $$ = Lnil; }
+ | core_prim_alts core_prim_alt { $$ = lapp($1, $2); }
+ ;
+
+core_prim_alt:
+ lit_constant RARROW core_expr SEMI { $$ = mkcoprim_alt($1, $3); }
+ ;
+
+core_default:
+ CO_NO_DEFAULT { $$ = mkconodeflt(); }
+ | core_binder RARROW core_expr { $$ = mkcobinddeflt($1, $3); }
+ ;
+
+corec_binds:
+ corec_bind { $$ = lsing($1); }
+ | corec_binds SEMI corec_bind { $$ = lapp($1, $3); }
+ ;
+
+corec_bind:
+ core_binder EQUAL core_expr { $$ = mkcorec_pair($1, $3); }
+ ;
+
+co_scc :
+ CO_PRELUDE_DICTS_CC co_dupd { $$ = mkco_preludedictscc($2); }
+ | CO_ALL_DICTS_CC STRING STRING co_dupd { $$ = mkco_alldictscc($2,$3,$4); }
+ | CO_USER_CC STRING STRING STRING co_dupd co_caf
+ { $$ = mkco_usercc($2,$3,$4,$5,$6); }
+ | CO_AUTO_CC core_id STRING STRING co_dupd co_caf
+ { $$ = mkco_autocc($2,$3,$4,$5,$6); }
+ | CO_DICT_CC core_id STRING STRING co_dupd co_caf
+ { $$ = mkco_dictcc($2,$3,$4,$5,$6); }
+
+co_caf : NO_PRAGMA { $$ = mkco_scc_noncaf(); }
+ | CO_CAF_CC { $$ = mkco_scc_caf(); }
+
+co_dupd : NO_PRAGMA { $$ = mkco_scc_nondupd(); }
+ | CO_DUPD_CC { $$ = mkco_scc_dupd(); }
+
+core_id: /* more to come?? */
+ CO_SDSEL_ID tycon tycon { $$ = mkco_sdselid($2, $3); }
+ | CO_METH_ID tycon var { $$ = mkco_classopid($2, $3); }
+ | CO_DEFM_ID tycon var { $$ = mkco_defmid($2, $3); }
+ | CO_DFUN_ID tycon OPAREN core_type CPAREN
+ { $$ = mkco_dfunid($2, $4); }
+ | CO_CONSTM_ID tycon var OPAREN core_type CPAREN
+ { $$ = mkco_constmid($2, $3, $5); }
+ | CO_SPEC_ID core_id OBRACK core_type_maybes CBRACK
+ { $$ = mkco_specid($2, $4); }
+ | CO_WRKR_ID core_id { $$ = mkco_wrkrid($2); }
+ | CO_ORIG_NM modid var { $$ = mkco_orig_id($2, $3); }
+ | CO_ORIG_NM modid con { $$ = mkco_orig_id($2, $3); }
+ | var { $$ = mkco_id($1); }
+ | con { $$ = mkco_id($1); }
+ ;
+
+co_primop :
+ OPAREN CCALL ccallid OCURLY core_types core_type CCURLY CPAREN
+ { $$ = mkco_ccall($3,0,$5,$6); }
+ | OPAREN CCALL_GC ccallid OCURLY core_types core_type CCURLY CPAREN
+ { $$ = mkco_ccall($3,1,$5,$6); }
+ | OPAREN CASM lit_constant OCURLY core_types core_type CCURLY CPAREN
+ { $$ = mkco_casm($3,0,$5,$6); }
+ | OPAREN CASM_GC lit_constant OCURLY core_types core_type CCURLY CPAREN
+ { $$ = mkco_casm($3,1,$5,$6); }
+ | VARID { $$ = mkco_primop($1); }
+ ;
+
+core_binders :
+ /* empty */ { $$ = Lnil; }
+ | core_binders core_binder { $$ = lapp($1, $2); }
+ ;
+
+core_binder :
+ OPAREN VARID DCOLON core_type CPAREN { $$ = mkcobinder($2, $4); }
+
+core_atoms :
+ OBRACK CBRACK { $$ = Lnil; }
+ | OBRACK core_atom_list CBRACK { $$ = $2; }
+ ;
+
+core_atom_list :
+ core_atom { $$ = lsing($1); }
+ | core_atom_list COMMA core_atom { $$ = lapp($1, $3); }
+ ;
+
+core_atom :
+ lit_constant { $$ = mkcolit($1); }
+ | core_id { $$ = mkcolocal($1); }
+ ;
+
+core_tyvars :
+ VARID { $$ = lsing($1); }
+ | core_tyvars VARID { $$ = lapp($1, $2); }
+ ;
+
+core_tv_templates :
+ TYVAR_TEMPLATE_ID { $$ = lsing($1); }
+ | core_tv_templates COMMA TYVAR_TEMPLATE_ID { $$ = lapp($1, $3); }
+ ;
+
+core_types :
+ OBRACK CBRACK { $$ = Lnil; }
+ | OBRACK core_type_list CBRACK { $$ = $2; }
+ ;
+
+core_type_list :
+ core_type { $$ = lsing($1); }
+ | core_type_list COMMA core_type { $$ = lapp($1, $3); }
+ ;
+
+core_type :
+ type { $$ = $1; }
+ ;
+
+/*
+core_type :
+ FORALL core_tv_templates DARROW core_type
+ { $$ = mkuniforall($2, $4); }
+ | OCURLY OCURLY CONID core_type CCURLY CCURLY RARROW core_type
+ { $$ = mktfun(mkunidict($3, $4), $8); }
+ | OCURLY OCURLY CONID core_type CCURLY CCURLY
+ { $$ = mkunidict($3, $4); }
+ | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN RARROW core_type
+ { $$ = mktfun(mkttuple(mklcons(mkunidict($4, $5), $9)), $12); }
+ | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN
+ { $$ = mkttuple(mklcons(mkunidict($4,$5), $9)); }
+ | type { $$ = $1; }
+ ;
+*/
+
+core_type_maybes:
+ core_type_maybe { $$ = lsing($1); }
+ | core_type_maybes COMMA core_type_maybe { $$ = lapp($1, $3); }
+ ;
+
+core_type_maybe:
+ NO_PRAGMA { $$ = mknothing(); }
+ | core_type { $$ = mkjust($1); }
+ ;
+
+
+/**********************************************************************
+* *
+* *
+* Fixes and Decls etc *
+* *
+* *
+**********************************************************************/
+
+maybefixes: /* empty */ { $$ = Lnil; }
+ | fixes SEMI { $$ = $1; }
+ ;
+
+fixes : fix { $$ = $1; }
+ | fixes SEMI fix { $$ = lconc($1,$3); }
+ ;
+
+fix : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; }
+ ops { $$ = $4; }
+ | INFIXR INTEGER { Precedence = checkfixity($2); Fixity = INFIXR; }
+ ops { $$ = $4; }
+ | INFIX INTEGER { Precedence = checkfixity($2); Fixity = INFIX; }
+ ops { $$ = $4; }
+ | INFIXL { Fixity = INFIXL; Precedence = 9; }
+ ops { $$ = $3; }
+ | INFIXR { Fixity = INFIXR; Precedence = 9; }
+ ops { $$ = $3; }
+ | INFIX { Fixity = INFIX; Precedence = 9; }
+ ops { $$ = $3; }
+ ;
+
+ops : op { makeinfix($1,Fixity,Precedence,the_module_name,
+ inimport,importas,importmod,asmod,importqual,
+ importspec,importhide,importlist);
+ $$ = lsing(mkfixop($1,infixint(Fixity),Precedence));
+ }
+ | ops COMMA op { makeinfix($3,Fixity,Precedence,the_module_name,
+ inimport,importas,importmod,asmod,importqual,
+ importspec,importhide,importlist);
+ $$ = lapp($1,mkfixop($3,infixint(Fixity),Precedence));
+ }
+ ;
+
+topdecls: topdecl
+ | topdecls SEMI topdecl
+ {
+ if($1 != NULL)
+ if($3 != NULL)
+ if(SAMEFN)
+ {
+ extendfn($1,$3);
+ $$ = $1;
+ }
+ else
+ $$ = mkabind($1,$3);
+ else
+ $$ = $1;
+ else
+ $$ = $3;
+ SAMEFN = 0;
+ }
+ ;
+
+topdecl : typed { $$ = $1; }
+ | datad { $$ = $1; }
+ | newtd { $$ = $1; }
+ | classd { $$ = $1; }
+ | instd { $$ = $1; }
+ | defaultd { $$ = $1; }
+ | decl { $$ = $1; }
+ ;
+
+typed : typekey simple EQUAL type { $$ = mknbind($2,$4,startlineno); }
+ ;
+
+
+datad : datakey simple EQUAL constrs
+ { $$ = mktbind(Lnil,$2,$4,mknothing(),startlineno,mkno_pragma()); }
+ | datakey simple EQUAL constrs DERIVING dtyclses
+ { $$ = mktbind(Lnil,$2,$4,mkjust($6),startlineno,mkno_pragma()); }
+ | datakey context DARROW simple EQUAL constrs
+ { $$ = mktbind($2,$4,$6,mknothing(),startlineno,mkno_pragma()); }
+ | datakey context DARROW simple EQUAL constrs DERIVING dtyclses
+ { $$ = mktbind($2,$4,$6,mkjust($8),startlineno,mkno_pragma()); }
+ ;
+
+newtd : newtypekey simple EQUAL constr1
+ { $$ = mkntbind(Lnil,$2,$4,mknothing(),startlineno,mkno_pragma()); }
+ | newtypekey simple EQUAL constr1 DERIVING dtyclses
+ { $$ = mkntbind(Lnil,$2,$4,mkjust($6),startlineno,mkno_pragma()); }
+ | newtypekey context DARROW simple EQUAL constr1
+ { $$ = mkntbind($2,$4,$6,mknothing(),startlineno,mkno_pragma()); }
+ | newtypekey context DARROW simple EQUAL constr1 DERIVING dtyclses
+ { $$ = mkntbind($2,$4,$6,mkjust($8),startlineno,mkno_pragma()); }
+ ;
+
+classd : classkey context DARROW class cbody { $$ = mkcbind($2,$4,$5,startlineno,mkno_pragma()); }
+ | classkey class cbody { $$ = mkcbind(Lnil,$2,$3,startlineno,mkno_pragma()); }
+ ;
+
+cbody : /* empty */ { $$ = mknullbind(); }
+ | WHERE ocurly decls ccurly { checkorder($3); $$ = $3; }
+ | WHERE vocurly decls vccurly { checkorder($3); $$ = $3; }
+ ;
+
+instd : instkey context DARROW gtycon restrict_inst rinst
+ { $$ = mkibind(1/*source*/,the_module_name,$2,$4,$5,$6,startlineno,mkno_pragma()); }
+ | instkey gtycon general_inst rinst
+ { $$ = mkibind(1/*source*/,the_module_name,Lnil,$2,$3,$4,startlineno,mkno_pragma()); }
+ ;
+
+rinst : /* empty */ { $$ = mknullbind(); }
+ | WHERE ocurly instdefs ccurly { $$ = $3; }
+ | WHERE vocurly instdefs vccurly { $$ = $3; }
+ ;
+
+restrict_inst : gtycon { $$ = mktname($1); }
+ | OPAREN gtyconvars CPAREN { $$ = $2; }
+ | OPAREN tyvar COMMA tyvar_list CPAREN { $$ = mkttuple(mklcons($2,$4)); }
+ | OBRACK tyvar CBRACK { $$ = mktllist($2); }
+ | OPAREN tyvar RARROW tyvar CPAREN { $$ = mktfun($2,$4); }
+ ;
+
+general_inst : gtycon { $$ = mktname($1); }
+ | OPAREN gtyconapp CPAREN { $$ = $2; }
+ | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
+ | OBRACK type CBRACK { $$ = mktllist($2); }
+ | OPAREN btype RARROW type CPAREN { $$ = mktfun($2,$4); }
+ ;
+
+defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); }
+ | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
+ ;
+
+decls : decl
+ | decls SEMI decl
+ {
+ if(SAMEFN)
+ {
+ extendfn($1,$3);
+ $$ = $1;
+ }
+ else
+ $$ = mkabind($1,$3);
+ }
+ ;
+
+
+/*
+ Note: if there is an iclasop_pragma here, then we must be
+ doing a class-op in an interface -- unless the user is up
+ to real mischief (ugly, but likely to work).
+*/
+
+decl : qvarsk DCOLON ctype iclasop_pragma
+ { $$ = mksbind($1,$3,startlineno,$4);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+ /* User-specified pragmas come in as "signatures"...
+ They are similar in that they can appear anywhere in the module,
+ and have to be "joined up" with their related entity.
+
+ Have left out the case specialising to an overloaded type.
+ Let's get real, OK? (WDP)
+ */
+ | SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
+ {
+ $$ = mkvspec_uprag($2, $4, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
+ | SPECIALISE_UPRAGMA INSTANCE gtycon general_inst END_UPRAGMA
+ {
+ $$ = mkispec_uprag($3, $4, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
+ | SPECIALISE_UPRAGMA DATA gtycon atypes END_UPRAGMA
+ {
+ $$ = mkdspec_uprag($3, $4, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
+ | INLINE_UPRAGMA qvark END_UPRAGMA
+ {
+ $$ = mkinline_uprag($2, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
+ | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
+ {
+ $$ = mkmagicuf_uprag($2, $3, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
+ | DEFOREST_UPRAGMA qvark END_UPRAGMA
+ {
+ $$ = mkdeforest_uprag($2, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
+ /* end of user-specified pragmas */
+
+ | valdef
+ | /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
+ ;
+
+qvarsk : qvark COMMA qvars_list { $$ = mklcons($1,$3); }
+ | qvark { $$ = lsing($1); }
+ ;
+
+qvars_list: qvar { $$ = lsing($1); }
+ | qvars_list COMMA qvar { $$ = lapp($1,$3); }
+ ;
+
+types_and_maybe_ids :
+ type_and_maybe_id { $$ = lsing($1); }
+ | types_and_maybe_ids COMMA type_and_maybe_id { $$ = lapp($1,$3); }
+ ;
+
+type_and_maybe_id :
+ type { $$ = mkvspec_ty_and_id($1,mknothing()); }
+ | type EQUAL qvark { $$ = mkvspec_ty_and_id($1,mkjust($3)); }
+
+
+/**********************************************************************
+* *
+* *
+* Types etc *
+* *
+* *
+**********************************************************************/
+
+/* "DCOLON context => type" vs "DCOLON type" is a problem,
+ because you can't distinguish between
+
+ foo :: (Baz a, Baz a)
+ bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
+
+ with one token of lookahead. The HACK is to have "DCOLON ttype"
+ [tuple type] in the first case, then check that it has the right
+ form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
+ context. Blaach!
+*/
+
+ /* 1 S/R conflict at DARROW -> shift */
+ctype : type DARROW type { $$ = mkcontext(type2context($1),$3); }
+ | type
+ ;
+
+ /* 1 S/R conflict at RARROW -> shift */
+type : btype { $$ = $1; }
+ | btype RARROW type { $$ = mktfun($1,$3); }
+
+ | FORALL core_tv_templates DARROW type { $$ = mkuniforall($2, $4); }
+ ;
+
+/* btype is split so we can parse gtyconapp without S/R conflicts */
+btype : gtyconapp { $$ = $1; }
+ | ntyconapp { $$ = $1; }
+ ;
+
+ntyconapp: ntycon { $$ = $1; }
+ | ntyconapp atype { $$ = mktapp($1,$2); }
+ ;
+
+gtyconapp: gtycon { $$ = mktname($1); }
+ | gtyconapp atype { $$ = mktapp($1,$2); }
+ ;
+
+
+atype : gtycon { $$ = mktname($1); }
+ | ntycon { $$ = $1; }
+ ;
+
+ntycon : tyvar { $$ = $1; }
+ | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
+ | OBRACK type CBRACK { $$ = mktllist($2); }
+ | OPAREN type CPAREN { $$ = $2; }
+
+ | OCURLY OCURLY gtycon type CCURLY CCURLY { $$ = mkunidict($3, $4); }
+ | TYVAR_TEMPLATE_ID { $$ = mkunityvartemplate($1); }
+ ;
+
+gtycon : qtycon
+ | OPAREN RARROW CPAREN { $$ = creategid(-2); }
+ | OBRACK CBRACK { $$ = creategid(-1); }
+ | OPAREN CPAREN { $$ = creategid(0); }
+ | OPAREN commas CPAREN { $$ = creategid($2); }
+ ;
+
+atypes : atype { $$ = lsing($1); }
+ | atypes atype { $$ = lapp($1,$2); }
+ ;
+
+types : type { $$ = lsing($1); }
+ | types COMMA type { $$ = lapp($1,$3); }
+ ;
+
+commas : COMMA { $$ = 1; }
+ | commas COMMA { $$ = $1 + 1; }
+ ;
+
+/**********************************************************************
+* *
+* *
+* Declaration stuff *
+* *
+* *
+**********************************************************************/
+
+simple : gtycon { $$ = mktname($1); }
+ | gtyconvars { $$ = $1; }
+ ;
+
+gtyconvars: gtycon tyvar { $$ = mktapp(mktname($1),$2); }
+ | gtyconvars tyvar { $$ = mktapp($1,$2); }
+ ;
+
+context : OPAREN context_list CPAREN { $$ = $2; }
+ | class { $$ = lsing($1); }
+ ;
+
+context_list: class { $$ = lsing($1); }
+ | context_list COMMA class { $$ = lapp($1,$3); }
+ ;
+
+class : gtycon tyvar { $$ = mktapp(mktname($1),$2); }
+ ;
+
+constrs : constr { $$ = lsing($1); }
+ | constrs VBAR constr { $$ = lapp($1,$3); }
+ ;
+
+constr : btyconapp { qid tyc; list tys;
+ splittyconapp($1, &tyc, &tys);
+ $$ = mkconstrpre(tyc,tys,hsplineno); }
+ | OPAREN qconsym CPAREN { $$ = mkconstrpre($2,Lnil,hsplineno); }
+ | OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); }
+ | btyconapp qconop bbtype { checknobangs($1);
+ $$ = mkconstrinf($1,$2,$3,hsplineno); }
+ | ntyconapp qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
+ | BANG atype qconop bbtype { $$ = mkconstrinf(mktbang($2),$3,$4,hsplineno); }
+
+ /* 1 S/R conflict on OCURLY -> shift */
+ | gtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
+ ;
+
+btyconapp: gtycon { $$ = mktname($1); }
+ | btyconapp batype { $$ = mktapp($1,$2); }
+ ;
+
+bbtype : btype { $$ = $1; }
+ | BANG atype { $$ = mktbang($2); }
+ ;
+
+batype : atype { $$ = $1; }
+ | BANG atype { $$ = mktbang($2); }
+ ;
+
+batypes : batype { $$ = lsing($1); }
+ | batypes batype { $$ = lapp($1,$2); }
+ ;
+
+
+fields : field { $$ = lsing($1); }
+ | fields COMMA field { $$ = lapp($1,$3); }
+ ;
+
+field : qvars_list DCOLON type { $$ = mkfield($1,$3); }
+ | qvars_list DCOLON BANG atype { $$ = mkfield($1,mktbang($4)); }
+ ;
+
+constr1 : gtycon atype { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
+ ;
+
+
+dtyclses: OPAREN dtycls_list CPAREN { $$ = $2; }
+ | OPAREN CPAREN { $$ = Lnil; }
+ | qtycls { $$ = lsing($1); }
+ ;
+
+dtycls_list: qtycls { $$ = lsing($1); }
+ | dtycls_list COMMA qtycls { $$ = lapp($1,$3); }
+ ;
+
+instdefs : /* empty */ { $$ = mknullbind(); }
+ | instdef { $$ = $1; }
+ | instdefs SEMI instdef
+ {
+ if(SAMEFN)
+ {
+ extendfn($1,$3);
+ $$ = $1;
+ }
+ else
+ $$ = mkabind($1,$3);
+ }
+ ;
+
+/* instdef: same as valdef, except certain user-pragmas may appear */
+instdef :
+ SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
+ {
+ $$ = mkvspec_uprag($2, $4, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
+ | INLINE_UPRAGMA qvark END_UPRAGMA
+ {
+ $$ = mkinline_uprag($2, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
+ | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
+ {
+ $$ = mkmagicuf_uprag($2, $3, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
+ | valdef
+ ;
+
+
+valdef : opatk
+ {
+ tree fn = function($1);
+ PREVPATT = $1;
+
+ if(ttree(fn) == ident)
+ {
+ qid fun_id = gident((struct Sident *) fn);
+ checksamefn(fun_id);
+ FN = fun_id;
+ }
+
+ else if (ttree(fn) == infixap)
+ {
+ qid fun_id = ginffun((struct Sinfixap *) fn);
+ checksamefn(fun_id);
+ FN = fun_id;
+ }
+
+ else if(etags)
+#if 1/*etags*/
+ printf("%u\n",startlineno);
+#else
+ fprintf(stderr,"%u\tvaldef\n",startlineno);
+#endif
+ }
+ valrhs
+ {
+ if ( lhs_is_patt($1) )
+ {
+ $$ = mkpbind($3, startlineno);
+ FN = NULL;
+ SAMEFN = 0;
+ }
+ else /* lhs is function */
+ $$ = mkfbind($3,startlineno);
+
+ PREVPATT = NULL;
+ }
+ ;
+
+valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); }
+ ;
+
+valrhs1 : gdrhs { $$ = mkpguards($1); }
+ | EQUAL exp { $$ = mkpnoguards($2); }
+ ;
+
+gdrhs : gd EQUAL exp { $$ = lsing(mkpgdexp($1,$3)); }
+ | gd EQUAL exp gdrhs { $$ = mklcons(mkpgdexp($1,$3),$4); }
+ ;
+
+maybe_where:
+ WHERE ocurly decls ccurly { $$ = $3; }
+ | WHERE vocurly decls vccurly { $$ = $3; }
+ | /* empty */ { $$ = mknullbind(); }
+ ;
+
+gd : VBAR oexp { $$ = $2; }
+ ;
+
+
+/**********************************************************************
+* *
+* *
+* Expressions *
+* *
+* *
+**********************************************************************/
+
+exp : oexp DCOLON ctype { $$ = mkrestr($1,$3); }
+ | oexp
+ ;
+
+/*
+ Operators must be left-associative at the same precedence for
+ precedence parsing to work.
+*/
+ /* 9 S/R conflicts on qop -> shift */
+oexp : oexp qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); precparse($$); }
+ | dexp
+ ;
+
+/*
+ This comes here because of the funny precedence rules concerning
+ prefix minus.
+*/
+dexp : MINUS kexp { $$ = mknegate($2,NULL,NULL); }
+ | kexp
+ ;
+
+/*
+ We need to factor out a leading let expression so we can set
+ inpat=TRUE when parsing (non let) expressions inside stmts and quals
+*/
+expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); }
+ | oexpLno
+ ;
+oexpLno : oexpLno qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); precparse($$); }
+ | dexpLno
+ ;
+dexpLno : MINUS kexp { $$ = mknegate($2,NULL,NULL); }
+ | kexpLno
+ ;
+
+expL : oexpL DCOLON ctype { $$ = mkrestr($1,$3); }
+ | oexpL
+ ;
+oexpL : oexpL qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); precparse($$); }
+ | kexpL
+ ;
+
+/*
+ let/if/lambda/case have higher precedence than infix operators.
+*/
+
+kexp : kexpL
+ | kexpLno
+ ;
+
+kexpL : letdecls IN exp { $$ = mklet($1,$3); }
+ ;
+
+kexpLno : LAMBDA
+ { hsincindent(); /* push new context for FN = NULL; */
+ FN = NULL; /* not actually concerned about indenting */
+ $<ulong>$ = hsplineno; /* remember current line number */
+ }
+ lampats
+ { hsendindent();
+ }
+ RARROW exp /* lambda abstraction */
+ {
+ $$ = mklambda($3, $6, $<ulong>2);
+ }
+
+ /* If Expression */
+ | IF {$<ulong>$ = hsplineno;}
+ exp THEN exp ELSE exp { $$ = mkife($3,$5,$7,$<ulong>2); }
+
+ /* Case Expression */
+ | CASE {$<ulong>$ = hsplineno;}
+ exp OF caserest { $$ = mkcasee($3,$5,$<ulong>2); }
+
+ /* Do Expression */
+ | DO {$<ulong>$ = hsplineno;}
+ dorest { $$ = mkdoe($3,$<ulong>2); }
+
+ /* CCALL/CASM Expression */
+ | CCALL ccallid cexps { $$ = mkccall($2,install_literal("n"),$3); }
+ | CCALL ccallid { $$ = mkccall($2,install_literal("n"),Lnil); }
+ | CCALL_GC ccallid cexps { $$ = mkccall($2,install_literal("p"),$3); }
+ | CCALL_GC ccallid { $$ = mkccall($2,install_literal("p"),Lnil); }
+ | CASM CLITLIT cexps { $$ = mkccall($2,install_literal("N"),$3); }
+ | CASM CLITLIT { $$ = mkccall($2,install_literal("N"),Lnil); }
+ | CASM_GC CLITLIT cexps { $$ = mkccall($2,install_literal("P"),$3); }
+ | CASM_GC CLITLIT { $$ = mkccall($2,install_literal("P"),Lnil); }
+
+ /* SCC Expression */
+ | SCC STRING exp
+ { if (ignoreSCC) {
+ $$ = $3;
+ } else {
+ $$ = mkscc($2, $3);
+ }
+ }
+ | fexp
+ ;
+
+fexp : fexp aexp { $$ = mkap($1,$2); }
+ | aexp
+ ;
+
+ /* simple expressions */
+aexp : qvar { $$ = mkident($1); }
+ | gcon { $$ = mkident($1); }
+ | lit_constant { $$ = mklit($1); }
+ | OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */
+ | qcon OCURLY rbinds CCURLY { $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */
+ | OBRACK list_exps CBRACK { $$ = mkllist($2); }
+ | OPAREN exp COMMA texps CPAREN { if (ttree($4) == tuple)
+ $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
+ else
+ $$ = mktuple(ldub($2, $4)); }
+
+ /* only in expressions ... */
+ | aexp OCURLY rbinds CCURLY { $$ = mkrupdate($1,$3); }
+ | OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); }
+ | OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
+ | OBRACK exp COMMA exp DOTDOT CBRACK { $$ = mkeenum($2,mkjust($4),mknothing()); }
+ | OBRACK exp DOTDOT exp CBRACK { $$ = mkeenum($2,mknothing(),mkjust($4)); }
+ | OBRACK exp DOTDOT CBRACK { $$ = mkeenum($2,mknothing(),mknothing()); }
+ | OPAREN oexp qop CPAREN { $$ = mklsection($2,$3); }
+ | OPAREN qop1 oexp CPAREN { $$ = mkrsection($2,$3); }
+
+ /* only in patterns ... */
+ /* these add 2 S/R conflict with with aexp . OCURLY rbinds CCURLY */
+ | qvar AT aexp { checkinpat(); $$ = mkas($1,$3); }
+ | LAZY aexp { checkinpat(); $$ = mklazyp($2); }
+ | WILDCARD { checkinpat(); $$ = mkwildp(); }
+ ;
+
+ /* ccall arguments */
+cexps : cexps aexp { $$ = lapp($1,$2); }
+ | aexp { $$ = lsing($1); }
+ ;
+
+caserest: ocurly alts ccurly { $$ = $2; }
+ | vocurly alts vccurly { $$ = $2; }
+
+dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; }
+ | vocurly stmts vccurly { checkdostmts($2); $$ = $2; }
+ ;
+
+rbinds : rbind { $$ = lsing($1); }
+ | rbinds COMMA rbind { $$ = lapp($1,$3); }
+ ;
+
+rbind : qvar { $$ = mkrbind($1,mknothing()); }
+ | qvar EQUAL exp { $$ = mkrbind($1,mkjust($3)); }
+ ;
+
+texps : exp { $$ = mkpar($1); } /* mkpar: so we don't flatten last element in tuple */
+ | exp COMMA texps
+ { if (ttree($3) == tuple)
+ $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
+ else
+ $$ = mktuple(ldub($1, $3));
+ }
+ /* right recursion? WDP */
+ ;
+
+
+list_exps :
+ exp { $$ = lsing($1); }
+ | exp COMMA list_exps { $$ = mklcons($1, $3); }
+ /* right recursion? (WDP)
+
+ It has to be this way, though, otherwise you
+ may do the wrong thing to distinguish between...
+
+ [ e1 , e2 .. ] -- an enumeration ...
+ [ e1 , e2 , e3 ] -- a list
+
+ (In fact, if you change the grammar and throw yacc/bison
+ at it, it *will* do the wrong thing [WDP 94/06])
+ */
+ ;
+
+letdecls: LET ocurly decls ccurly { $$ = $3 }
+ | LET vocurly decls vccurly { $$ = $3 }
+ ;
+
+quals : qual { $$ = lsing($1); }
+ | quals COMMA qual { $$ = lapp($1,$3); }
+ ;
+
+qual : letdecls { $$ = mkseqlet($1); }
+ | expL { $$ = $1; }
+ | {inpat=TRUE;} expLno {inpat=FALSE;}leftexp
+ { if ($4 == NULL) {
+ expORpat(LEGIT_EXPR,$2);
+ $$ = mkguard($2);
+ } else {
+ expORpat(LEGIT_PATT,$2);
+ $$ = mkqual($2,$4);
+ }
+ }
+ ;
+
+alts : alt { $$ = $1; }
+ | alts SEMI alt { $$ = lconc($1,$3); }
+ ;
+
+alt : pat { PREVPATT = $1; } altrest { $$ = lsing($3); PREVPATT = NULL; }
+ | /* empty */ { $$ = Lnil; }
+ ;
+
+altrest : gdpat maybe_where { $$ = createpat(mkpguards($1), $2); }
+ | RARROW exp maybe_where { $$ = createpat(mkpnoguards($2),$3); }
+ ;
+
+gdpat : gd RARROW exp { $$ = lsing(mkpgdexp($1,$3)); }
+ | gd RARROW exp gdpat { $$ = mklcons(mkpgdexp($1,$3),$4); }
+ ;
+
+stmts : stmt { $$ = $1; }
+ | stmts SEMI stmt { $$ = lconc($1,$3); }
+ ;
+
+stmt : /* empty */ { $$ = Lnil; }
+ | letdecls { $$ = lsing(mkseqlet($1)); }
+ | expL { $$ = lsing($1); }
+ | {inpat=TRUE;} expLno {inpat=FALSE;} leftexp
+ { if ($4 == NULL) {
+ expORpat(LEGIT_EXPR,$2);
+ $$ = lsing(mkdoexp($2,endlineno));
+ } else {
+ expORpat(LEGIT_PATT,$2);
+ $$ = lsing(mkdobind($2,$4,endlineno));
+ }
+ }
+ ;
+
+leftexp : LARROW exp { $$ = $2; }
+ | /* empty */ { $$ = NULL; }
+ ;
+
+/**********************************************************************
+* *
+* *
+* Patterns *
+* *
+* *
+**********************************************************************/
+
+/*
+ The xpatk business is to do with accurately recording
+ the starting line for definitions.
+*/
+
+opatk : dpatk
+ | opatk qop opat %prec MINUS
+ {
+ $$ = mkinfixap($2,$1,$3);
+
+ if (isconstr(qid_to_string($2)))
+ precparse($$);
+ else
+ {
+ checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */
+ checkprec($3,$2,TRUE); /* then check the right pattern */
+ }
+ }
+ ;
+
+opat : dpat
+ | opat qop opat %prec MINUS
+ {
+ $$ = mkinfixap($2,$1,$3);
+
+ if(isconstr(qid_to_string($2)))
+ precparse($$);
+ else
+ {
+ checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */
+ checkprec($3,$2,TRUE); /* then check the right pattern */
+ }
+ }
+ ;
+
+/*
+ This comes here because of the funny precedence rules concerning
+ prefix minus.
+*/
+
+
+dpat : MINUS fpat { $$ = mknegate($2,NULL,NULL); }
+ | fpat
+ ;
+
+ /* Function application */
+fpat : fpat aapat { $$ = mkap($1,$2); }
+ | aapat
+ ;
+
+dpatk : minuskey fpat { $$ = mknegate($2,NULL,NULL); }
+ | fpatk
+ ;
+
+ /* Function application */
+fpatk : fpatk aapat { $$ = mkap($1,$2); }
+ | aapatk
+ ;
+
+aapat : qvar { $$ = mkident($1); }
+ | qvar AT apat { $$ = mkas($1,$3); }
+ | gcon { $$ = mkident($1); }
+ | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
+ | lit_constant { $$ = mklit($1); }
+ | WILDCARD { $$ = mkwildp(); }
+ | OPAREN opat CPAREN { $$ = mkpar($2); }
+ | OPAREN opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
+ | OBRACK pats CBRACK { $$ = mkllist($2); }
+ | LAZY apat { $$ = mklazyp($2); }
+ ;
+
+
+aapatk : qvark { $$ = mkident($1); }
+ | qvark AT apat { $$ = mkas($1,$3); }
+ | gconk { $$ = mkident($1); }
+ | qconk OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
+ | lit_constant { $$ = mklit($1); setstartlineno(); }
+ | WILDCARD { $$ = mkwildp(); setstartlineno(); }
+ | oparenkey opat CPAREN { $$ = mkpar($2); }
+ | oparenkey opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
+ | obrackkey pats CBRACK { $$ = mkllist($2); }
+ | lazykey apat { $$ = mklazyp($2); }
+ ;
+
+gcon : qcon
+ | OBRACK CBRACK { $$ = creategid(-1); }
+ | OPAREN CPAREN { $$ = creategid(0); }
+ | OPAREN commas CPAREN { $$ = creategid($2); }
+ ;
+
+gconk : qconk
+ | obrackkey CBRACK { $$ = creategid(-1); }
+ | oparenkey CPAREN { $$ = creategid(0); }
+ | oparenkey commas CPAREN { $$ = creategid($2); }
+ ;
+
+lampats : apat lampats { $$ = mklcons($1,$2); }
+ | apat { $$ = lsing($1); }
+ /* right recursion? (WDP) */
+ ;
+
+pats : pat COMMA pats { $$ = mklcons($1, $3); }
+ | pat { $$ = lsing($1); }
+ /* right recursion? (WDP) */
+ ;
+
+pat : pat qconop bpat { $$ = mkinfixap($2,$1,$3); precparse($$); }
+ | bpat
+ ;
+
+bpat : apatc
+ | conpat
+ | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
+ | MINUS INTEGER { $$ = mklit(mkinteger(ineg($2))); }
+ | MINUS FLOAT { $$ = mklit(mkfloatr(ineg($2))); }
+ ;
+
+conpat : gcon { $$ = mkident($1); }
+ | conpat apat { $$ = mkap($1,$2); }
+ ;
+
+apat : gcon { $$ = mkident($1); }
+ | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
+ | apatc
+ ;
+
+apatc : qvar { $$ = mkident($1); }
+ | qvar AT apat { $$ = mkas($1,$3); }
+ | lit_constant { $$ = mklit($1); }
+ | WILDCARD { $$ = mkwildp(); }
+ | OPAREN pat CPAREN { $$ = mkpar($2); }
+ | OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
+ | OBRACK pats CBRACK { $$ = mkllist($2); }
+ | LAZY apat { $$ = mklazyp($2); }
+ ;
+
+lit_constant:
+ INTEGER { $$ = mkinteger($1); }
+ | FLOAT { $$ = mkfloatr($1); }
+ | CHAR { $$ = mkcharr($1); }
+ | STRING { $$ = mkstring($1); }
+ | CHARPRIM { $$ = mkcharprim($1); }
+ | STRINGPRIM { $$ = mkstringprim($1); }
+ | INTPRIM { $$ = mkintprim($1); }
+ | FLOATPRIM { $$ = mkfloatprim($1); }
+ | DOUBLEPRIM { $$ = mkdoubleprim($1); }
+ | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1, ""); }
+ | CLITLIT KIND_PRAGMA CONID { $$ = mkclitlit($1, $3); }
+ | NOREP_INTEGER INTEGER { $$ = mknorepi($2); }
+ | NOREP_RATIONAL INTEGER INTEGER { $$ = mknorepr($2, $3); }
+ | NOREP_STRING STRING { $$ = mknoreps($2); }
+ ;
+
+rpats : rpat { $$ = lsing($1); }
+ | rpats COMMA rpat { $$ = lapp($1,$3); }
+ ;
+
+rpat : qvar { $$ = mkrbind($1,mknothing()); }
+ | qvar EQUAL pat { $$ = mkrbind($1,mkjust($3)); }
+ ;
+
+
+/**********************************************************************
+* *
+* *
+* Keywords which record the line start *
+* *
+* *
+**********************************************************************/
+
+importkey: IMPORT { setstartlineno(); }
+ ;
+
+datakey : DATA { setstartlineno();
+ if(etags)
+#if 1/*etags*/
+ printf("%u\n",startlineno);
+#else
+ fprintf(stderr,"%u\tdata\n",startlineno);
+#endif
+ }
+ ;
+
+typekey : TYPE { setstartlineno();
+ if(etags)
+#if 1/*etags*/
+ printf("%u\n",startlineno);
+#else
+ fprintf(stderr,"%u\ttype\n",startlineno);
+#endif
+ }
+ ;
+
+newtypekey : NEWTYPE { setstartlineno();
+ if(etags)
+#if 1/*etags*/
+ printf("%u\n",startlineno);
+#else
+ fprintf(stderr,"%u\tnewtype\n",startlineno);
+#endif
+ }
+ ;
+
+instkey : INSTANCE { setstartlineno();
+#if 1/*etags*/
+/* OUT: if(etags)
+ printf("%u\n",startlineno);
+*/
+#else
+ fprintf(stderr,"%u\tinstance\n",startlineno);
+#endif
+ }
+ ;
+
+defaultkey: DEFAULT { setstartlineno(); }
+ ;
+
+classkey: CLASS { setstartlineno();
+ if(etags)
+#if 1/*etags*/
+ printf("%u\n",startlineno);
+#else
+ fprintf(stderr,"%u\tclass\n",startlineno);
+#endif
+ }
+ ;
+
+minuskey: MINUS { setstartlineno(); }
+ ;
+
+modulekey: MODULE { setstartlineno();
+ if(etags)
+#if 1/*etags*/
+ printf("%u\n",startlineno);
+#else
+ fprintf(stderr,"%u\tmodule\n",startlineno);
+#endif
+ }
+ ;
+
+oparenkey: OPAREN { setstartlineno(); }
+ ;
+
+obrackkey: OBRACK { setstartlineno(); }
+ ;
+
+lazykey : LAZY { setstartlineno(); }
+ ;
+
+
+/**********************************************************************
+* *
+* *
+* Basic qualified/unqualified ids/ops *
+* *
+* *
+**********************************************************************/
+
+qvar : qvarid
+ | OPAREN qvarsym CPAREN { $$ = $2; }
+ ;
+qcon : qconid
+ | OPAREN qconsym CPAREN { $$ = $2; }
+ ;
+qvarop : qvarsym
+ | BQUOTE qvarid BQUOTE { $$ = $2; }
+ ;
+qconop : qconsym
+ | BQUOTE qconid BQUOTE { $$ = $2; }
+ ;
+qop : qconop
+ | qvarop
+ ;
+
+/* Non "-" op, used in right sections */
+qop1 : qconop
+ | qvarop1
+ ;
+
+/* Non "-" varop, used in right sections */
+qvarop1 : QVARSYM
+ | varsym_nominus { $$ = mknoqual($1); }
+ | BQUOTE qvarid BQUOTE { $$ = $2; }
+ ;
+
+
+var : varid
+ | OPAREN varsym CPAREN { $$ = $2; }
+ ;
+con : tycon /* using tycon removes conflicts */
+ | OPAREN CONSYM CPAREN { $$ = $2; }
+ ;
+varop : varsym
+ | BQUOTE varid BQUOTE { $$ = $2; }
+ ;
+conop : CONSYM
+ | BQUOTE CONID BQUOTE { $$ = $2; }
+ ;
+op : conop
+ | varop
+ ;
+
+qvark : qvarid { setstartlineno(); $$ = $1; }
+ | oparenkey qvarsym CPAREN { $$ = $2; }
+ ;
+qconk : qconid { setstartlineno(); $$ = $1; }
+ | oparenkey qconsym CPAREN { $$ = $2; }
+ ;
+vark : varid { setstartlineno(); $$ = $1; }
+ | oparenkey varsym CPAREN { $$ = $2; }
+ ;
+
+qvarid : QVARID
+ | varid { $$ = mknoqual($1); }
+ ;
+qvarsym : QVARSYM
+ | varsym { $$ = mknoqual($1); }
+ ;
+qconid : QCONID
+ | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
+ ;
+qconsym : QCONSYM
+ | CONSYM { $$ = mknoqual($1); }
+ ;
+qtycon : QCONID
+ | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
+ ;
+qtycls : QCONID
+ | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
+ ;
+
+varsym : varsym_nominus
+ | MINUS { $$ = install_literal("-"); }
+ ;
+
+/* AS HIDING QUALIFIED are valid varids */
+varid : VARID
+ | AS { $$ = install_literal("as"); }
+ | HIDING { $$ = install_literal("hiding"); }
+ | QUALIFIED { $$ = install_literal("qualified"); }
+ | INTERFACE { $$ = install_literal("interface"); }
+ ;
+
+/* DARROW BANG are valid varsyms */
+varsym_nominus : VARSYM
+ | DARROW { $$ = install_literal("=>"); }
+ | BANG { $$ = install_literal("!"); }
+ ;
+
+ccallid : VARID
+ | CONID
+ ;
+
+tyvar : varid { $$ = mknamedtvar($1); }
+ ;
+tycon : CONID
+ ;
+modid : CONID
+ ;
+
+tyvar_list: tyvar { $$ = lsing($1); }
+ | tyvar_list COMMA tyvar { $$ = lapp($1,$3); }
+ ;
+
+/**********************************************************************
+* *
+* *
+* Stuff to do with layout *
+* *
+* *
+**********************************************************************/
+
+ocurly : layout OCURLY { hsincindent(); }
+
+vocurly : layout { hssetindent(); }
+ ;
+
+layout : { hsindentoff(); }
+ ;
+
+ccurly :
+ CCURLY
+ {
+ FN = NULL; SAMEFN = 0; PREVPATT = NULL;
+ hsendindent();
+ }
+ ;
+
+vccurly : { expect_ccurly = 1; } vccurly1 { expect_ccurly = 0; }
+ ;
+
+vccurly1:
+ VCCURLY
+ {
+ FN = NULL; SAMEFN = 0; PREVPATT = NULL;
+ hsendindent();
+ }
+ | error
+ {
+ yyerrok;
+ FN = NULL; SAMEFN = 0; PREVPATT = NULL;
+ hsendindent();
+ }
+ ;
+
+%%
+
+/**********************************************************************
+* *
+* Error Processing and Reporting *
+* *
+* (This stuff is here in case we want to use Yacc macros and such.) *
+* *
+**********************************************************************/
+
+/* The parser calls "hsperror" when it sees a
+ `report this and die' error. It sets the stage
+ and calls "yyerror".
+
+ There should be no direct calls in the parser to
+ "yyerror", except for the one from "hsperror". Thus,
+ the only other calls will be from the error productions
+ introduced by yacc/bison/whatever.
+
+ We need to be able to recognise the from-error-production
+ case, because we sometimes want to say, "Oh, never mind",
+ because the layout rule kicks into action and may save
+ the day. [WDP]
+*/
+
+static BOOLEAN error_and_I_mean_it = FALSE;
+
+void
+hsperror(s)
+ char *s;
+{
+ error_and_I_mean_it = TRUE;
+ yyerror(s);
+}
+
+extern char *yytext;
+extern int yyleng;
+
+void
+yyerror(s)
+ char *s;
+{
+ /* We want to be able to distinguish 'error'-raised yyerrors
+ from yyerrors explicitly coded by the parser hacker.
+ */
+ if (expect_ccurly && ! error_and_I_mean_it ) {
+ /*NOTHING*/;
+
+ } else {
+ fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ",
+ input_filename, hsplineno, hspcolno + 1, s);
+
+ if (yyleng == 1 && *yytext == '\0')
+ fprintf(stderr, "<EOF>");
+
+ else {
+ fputc('"', stderr);
+ format_string(stderr, (unsigned char *) yytext, yyleng);
+ fputc('"', stderr);
+ }
+ fputc('\n', stderr);
+
+ /* a common problem */
+ if (strcmp(yytext, "#") == 0)
+ fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
+
+ exit(1);
+ }
+}
+
+void
+format_string(fp, s, len)
+ FILE *fp;
+ unsigned char *s;
+ int len;
+{
+ while (len-- > 0) {
+ switch (*s) {
+ case '\0': fputs("\\NUL", fp); break;
+ case '\007': fputs("\\a", fp); break;
+ case '\010': fputs("\\b", fp); break;
+ case '\011': fputs("\\t", fp); break;
+ case '\012': fputs("\\n", fp); break;
+ case '\013': fputs("\\v", fp); break;
+ case '\014': fputs("\\f", fp); break;
+ case '\015': fputs("\\r", fp); break;
+ case '\033': fputs("\\ESC", fp); break;
+ case '\034': fputs("\\FS", fp); break;
+ case '\035': fputs("\\GS", fp); break;
+ case '\036': fputs("\\RS", fp); break;
+ case '\037': fputs("\\US", fp); break;
+ case '\177': fputs("\\DEL", fp); break;
+ default:
+ if (*s >= ' ')
+ fputc(*s, fp);
+ else
+ fprintf(fp, "\\^%c", *s + '@');
+ break;
+ }
+ s++;
+ }
+}
--- /dev/null
+#ifndef HSPINCL_H
+#define HSPINCL_H
+
+#include "../../includes/config.h"
+
+#if __STDC__
+#define PROTO(x) x
+#define NO_ARGS void
+#define CONST const
+#define VOID void
+#define VOID_STAR void *
+#define VOLATILE volatile
+#else
+#define PROTO(x) ()
+#define NO_ARGS /* no args */
+#define CONST /* no const */
+#define VOID void /* hope for the best... */
+#define VOID_STAR long *
+#define VOLATILE /* no volatile */
+#endif /* ! __STDC__ */
+
+#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
+#include <string.h>
+/* An ANSI string.h and pre-ANSI memory.h might conflict. */
+#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
+#include <memory.h>
+#endif /* not STDC_HEADERS and HAVE_MEMORY_H */
+#define index strchr
+#define rindex strrchr
+#define bcopy(s, d, n) memcpy ((d), (s), (n))
+#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
+#define bzero(s, n) memset ((s), 0, (n))
+#else /* not STDC_HEADERS and not HAVE_STRING_H */
+#include <strings.h>
+/* memory.h and strings.h conflict on some systems. */
+#endif /* not STDC_HEADERS and not HAVE_STRING_H */
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#include "id.h"
+#include "qid.h"
+#include "literal.h"
+#include "list.h"
+#include "maybe.h"
+#include "either.h"
+#include "ttype.h"
+#include "constr.h"
+#include "coresyn.h"
+#include "hpragma.h"
+#include "binding.h"
+#include "entidt.h"
+#include "tree.h"
+#include "pbinding.h"
+
+extern char *input_filename;
+
+#endif /* HSPINCL_H */
--- /dev/null
+/**********************************************************************
+* *
+* *
+* Identifier Processing *
+* *
+* *
+**********************************************************************/
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "id.h"
+#include "utils.h"
+
+/* partain: special version for strings that may have NULs (etc) in them
+ (used in UgenUtil.lhs)
+*/
+long
+get_hstring_len(hs)
+ hstring hs;
+{
+ return(hs->len);
+}
+
+char *
+get_hstring_bytes(hs)
+ hstring hs;
+{
+ return(hs->bytes);
+}
+
+hstring
+installHstring(length, s)
+ int length;
+ char *s;
+{
+ char *p;
+ hstring str;
+ int i;
+
+/* fprintf(stderr, "installHstring: %d, %s\n",length, s); */
+
+ if (length > 999999) { /* too long */
+ fprintf(stderr,"String length more than six digits\n");
+ exit(1);
+ } else if (length < 0) { /* too short */
+ fprintf(stderr,"String length < 0 !!\n");
+ abort();
+ }
+
+ /* alloc the struct and store the length */
+ str = (hstring) xmalloc(sizeof(Hstring));
+ str->len = length;
+
+ if (length == 0) {
+ str->bytes = NULL;
+
+ } else {
+ p = xmalloc(length);
+
+ /* now store the string */
+ for (i = 0; i < length; i++) {
+ p[i] = s[i];
+ }
+ str->bytes = p;
+ }
+ return str;
+}
+
+
+/**********************************************************************
+* *
+* *
+* Hashed Identifiers *
+* *
+* *
+**********************************************************************/
+
+
+extern BOOLEAN hashIds; /* Whether to use hashed ids. */
+
+unsigned hash_table_size = HASH_TABLE_SIZE;
+
+static char **hashtab = NULL;
+
+static unsigned max_hash_table_entries = 0;
+
+void
+hash_init()
+{
+ if(!hashIds) {
+ /*NOTHING*/;
+
+ } else {
+
+ /* Create an initialised hash table */
+ hashtab = (char **) calloc( hash_table_size, sizeof(char *) );
+ if(hashtab == NULL)
+ {
+ fprintf(stderr,"Cannot allocate a hash table with %d entries -- insufficient memory\n",hash_table_size);
+ exit(1);
+ }
+#ifdef HSP_DEBUG
+ fprintf(stderr,"hashtab = %x\n",hashtab);
+#endif
+
+ /* Allow no more than 90% occupancy -- Divide first to avoid overflows with BIG tables! */
+ max_hash_table_entries = (hash_table_size / 10) * 9;
+ }
+}
+
+void
+print_hash_table()
+{
+ if(hashIds)
+ {
+ unsigned i;
+
+ printf("%u ",hash_table_size);
+
+ for(i=0; i < hash_table_size; ++i)
+ if(hashtab[i] != NULL)
+ printf("(%u,%s) ",i,hashtab[i]);
+ }
+}
+
+
+long int
+hash_index(ident)
+ id ident;
+{
+ return((char **) /* YURGH */ ident - hashtab);
+}
+
+
+/*
+ The hash function. Returns 0 for Null strings.
+*/
+
+static unsigned hash_fn(char *ident)
+{
+ unsigned len = (unsigned) strlen(ident);
+ unsigned res;
+
+ if(*ident == '\0')
+ return( 0 );
+
+ /* does not work well for hash tables with more than 35K elements */
+ res = (((unsigned)ident[0]*631)+((unsigned)ident[len/2-1]*217)+((unsigned)ident[len-1]*43)+len)
+ % hash_table_size;
+
+#ifdef HSP_DEBUG
+ fprintf(stderr,"\"%s\" hashes to %d\n",ident,res);
+#endif
+ return(res);
+}
+
+
+/*
+ Install a literal identifier, such as "+" in hsparser.
+ If we are not using hashing, just return the string.
+*/
+
+id
+install_literal(s)
+ char *s;
+{
+ return( hashIds? installid(s): s);
+}
+
+
+char *
+id_to_string(sp)
+ id sp;
+{
+ return( hashIds? *(char **)sp: (char *)sp );
+}
+
+id
+installid(s)
+ char *s;
+{
+ unsigned hash, count;
+
+ if(!hashIds)
+ return(xstrdup(s));
+
+ for(hash = hash_fn(s),count=0; count<max_hash_table_entries; ++hash,++count)
+ {
+ if (hash >= hash_table_size) hash = 0;
+
+ if(hashtab[hash] == NULL)
+ {
+ hashtab[hash] = xstrdup(s);
+#ifdef HSP_DEBUG
+ fprintf(stderr,"New Hash Entry %x\n",(char *)&hashtab[hash]);
+#endif
+ if ( count >= 100 ) {
+ fprintf(stderr, "installid: %d collisions for %s\n", count, s);
+ }
+
+ return((char *)&hashtab[hash]);
+ }
+
+ if(strcmp(hashtab[hash],s) == 0)
+ {
+#ifdef HSP_DEBUG
+ fprintf(stderr,"Old Hash Entry %x (%s)\n",(char *)&hashtab[hash],hashtab[hash]);
+#endif
+ if ( count >= 100 ) {
+ fprintf(stderr, "installid: %d collisions for %s\n", count, s);
+ }
+
+ return((char *)&hashtab[hash]);
+ }
+ }
+ fprintf(stderr,"Hash Table Contains more than %d entries -- make larger?\n",max_hash_table_entries);
+ exit(1);
+}
+
+/**********************************************************************
+* *
+* *
+* Qualified Ids *
+* *
+* *
+**********************************************************************/
+
+id
+qid_to_id(q)
+ qid q;
+{
+ switch(tqid(q))
+ {
+ case noqual:
+ return(gnoqual((struct Snoqual *)q));
+ case aqual:
+ return(gqualname((struct Saqual *)q));
+ case gid:
+ return(gidname((struct Sgid *)q));
+ }
+}
+
+char *
+qid_to_string(q)
+ qid q;
+{
+ return(id_to_string(qid_to_id(q)));
+}
+
+char *
+qid_to_mod(q)
+ qid q;
+{
+ switch(tqid(q))
+ {
+ case noqual:
+ return(NULL);
+ case aqual:
+ return(id_to_string(gqualmod((struct Saqual *)q)));
+ case gid:
+ return(NULL);
+ }
+}
+
+char *
+qid_to_pmod(q)
+ qid q;
+{
+ char *mod = qid_to_mod(q);
+ if (mod == NULL) mod = "?";
+ return mod;
+}
+
+qid
+creategid(i)
+ long i;
+{
+ switch(i) {
+ case -2:
+ return(mkgid(i,install_literal("(->)")));
+ case -1:
+ return(mkgid(i,install_literal("[]")));
+ case 0:
+ return(mkgid(i,install_literal("()")));
+ default:
+ {
+ char tmp[64]; int c = 0;
+ tmp[c++] = '(';
+ while (c <= i) tmp[c++] = ',';
+ tmp[c++] = ')';
+ tmp[c] = '\0';
+ return(mkgid(i,installid(tmp)));
+ }
+ }
+}
+
+/**********************************************************************
+* *
+* *
+* Memory Allocation *
+* *
+* *
+**********************************************************************/
+
+/* Malloc with error checking */
+
+char *
+xmalloc(length)
+unsigned length;
+{
+ char *stuff = malloc(length);
+
+ if (stuff == NULL) {
+ fprintf(stderr, "xmalloc failed on a request for %d bytes\n", length);
+ exit(1);
+ }
+ return (stuff);
+}
+
+char *
+xrealloc(ptr, length)
+char *ptr;
+unsigned length;
+{
+ char *stuff = realloc(ptr, length);
+
+ if (stuff == NULL) {
+ fprintf(stderr, "xrealloc failed on a request for %d bytes\n", length);
+ exit(1);
+ }
+ return (stuff);
+}
+
+/* Strdup with error checking */
+
+char *
+xstrdup(s)
+char *s;
+{
+ unsigned len = strlen(s);
+ return xstrndup(s, len);
+}
+
+/*
+ * Strdup for possibly unterminated strings (e.g. substrings of longer strings)
+ * with error checking. Handles NULs as well.
+ */
+
+char *
+xstrndup(s, len)
+char *s;
+unsigned len;
+{
+ char *p = xmalloc(len + 1);
+
+ bcopy(s, p, len);
+ p[len] = '\0';
+
+ return (p);
+}
--- /dev/null
+#ifndef ID_H
+#define ID_H
+
+typedef char *id;
+typedef id unkId; /* synonym */
+typedef id stringId; /* synonym */
+typedef id numId; /* synonym, for now */
+
+typedef struct { long len; char *bytes; } Hstring;
+typedef Hstring *hstring;
+
+long get_hstring_len PROTO((hstring));
+char *get_hstring_bytes PROTO((hstring));
+
+#endif
--- /dev/null
+/**********************************************************************
+* *
+* *
+* Import Directory List Handling *
+* *
+* *
+**********************************************************************/
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#else
+#ifdef HAVE_TYPES_H
+#include <types.h>
+#endif
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+#ifdef HAVE_SYS_FILE_H
+#include <sys/file.h>
+#endif
+
+#ifndef HAVE_ACCESS
+#define R_OK "r"
+#define F_OK "r"
+short
+access(const char *fileName, const char *mode)
+{
+ FILE *fp = fopen(fileName, mode);
+ if (fp != NULL) {
+ (void) fclose(fp);
+ return 0;
+ }
+ return 1;
+}
+#endif /* HAVE_ACCESS */
+
+
+list imports_dirlist, sys_imports_dirlist; /* The imports lists */
+extern char HiSuffix[];
+extern char PreludeHiSuffix[];
+/* OLD 95/08: extern BOOLEAN ExplicitHiSuffixGiven; */
+
+#define MAX_MATCH 16
+
+/*
+ This finds a module along the imports directory list.
+*/
+
+void
+find_module_on_imports_dirlist(char *module_name, BOOLEAN is_sys_import, char *returned_filename)
+{
+ char try[FILENAME_SIZE];
+
+ list imports_dirs;
+
+#ifdef HAVE_STAT
+ struct stat sbuf[MAX_MATCH];
+#endif
+
+ int no_of_matches = 0;
+ BOOLEAN tried_source_dir = FALSE;
+
+ char *try_end;
+ char *suffix_to_use = (is_sys_import) ? PreludeHiSuffix : HiSuffix;
+ char *suffix_to_report = suffix_to_use; /* save this for reporting, because we
+ might change suffix_to_use later */
+ int modname_len = strlen(module_name);
+
+ /*
+ Check every directory in (sys_)imports_dirlist for the imports file.
+ The first directory in the list is the source directory.
+ */
+ for (imports_dirs = (is_sys_import) ? sys_imports_dirlist : imports_dirlist;
+ tlist(imports_dirs) == lcons;
+ imports_dirs = ltl(imports_dirs))
+ {
+ char *dir = (char *) lhd(imports_dirs);
+ strcpy(try, dir);
+
+ try_end = try + strlen(try);
+
+#ifdef macintosh /* ToDo: use DIR_SEP_CHAR */
+ if (*(try_end - 1) != ':')
+ strcpy (try_end++, ":");
+#else
+ if (*(try_end - 1) != '/')
+ strcpy (try_end++, "/");
+#endif /* ! macintosh */
+
+ strcpy(try_end, module_name);
+
+ strcpy(try_end+modname_len, suffix_to_use);
+
+ /* See whether the file exists and is readable. */
+ if (access (try,R_OK) == 0)
+ {
+ if ( no_of_matches == 0 )
+ strcpy(returned_filename, try);
+
+ /* Return as soon as a match is found in the source directory. */
+ if (!tried_source_dir)
+ return;
+
+#ifdef HAVE_STAT
+ if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 )
+ {
+ int i;
+ for (i = 0; i < no_of_matches; i++)
+ {
+ if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev &&
+ sbuf[no_of_matches].st_ino == sbuf[i].st_ino)
+ goto next; /* Skip dups */
+ }
+ }
+#endif /* HAVE_STAT */
+ no_of_matches++;
+ }
+ else if (access (try,F_OK) == 0)
+ fprintf(stderr,"Warning: %s exists, but is not readable\n",try);
+
+ next:
+ tried_source_dir = TRUE;
+ }
+
+ if ( no_of_matches == 0 && ! is_sys_import ) { /* Nothing so far */
+
+ /* If we are explicitly meddling about with .hi suffixes,
+ then some system-supplied modules may need to be looked
+ for with PreludeHiSuffix; unsavoury but true...
+ */
+ suffix_to_use = PreludeHiSuffix;
+
+ for (imports_dirs = sys_imports_dirlist;
+ tlist(imports_dirs) == lcons;
+ imports_dirs = ltl(imports_dirs))
+ {
+ char *dir = (char *) lhd(imports_dirs);
+ strcpy(try, dir);
+
+ try_end = try + strlen(try);
+
+#ifdef macintosh /* ToDo: use DIR_SEP_STRING */
+ if (*(try_end - 1) != ':')
+ strcpy (try_end++, ":");
+#else
+ if (*(try_end - 1) != '/')
+ strcpy (try_end++, "/");
+#endif /* ! macintosh */
+
+ strcpy(try_end, module_name);
+
+ strcpy(try_end+modname_len, suffix_to_use);
+
+ /* See whether the file exists and is readable. */
+ if (access (try,R_OK) == 0)
+ {
+ if ( no_of_matches == 0 )
+ strcpy(returned_filename, try);
+
+#ifdef HAVE_STAT
+ if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 )
+ {
+ int i;
+ for (i = 0; i < no_of_matches; i++)
+ {
+ if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev &&
+ sbuf[no_of_matches].st_ino == sbuf[i].st_ino)
+ goto next_again; /* Skip dups */
+ }
+ }
+#endif /* HAVE_STAT */
+ no_of_matches++;
+ }
+ else if (access (try,F_OK) == 0)
+ fprintf(stderr,"Warning: %s exists, but is not readable\n",try);
+ next_again:
+ /*NOTHING*/;
+ }
+ }
+
+ /* Error checking */
+
+ switch ( no_of_matches ) {
+ default:
+ fprintf(stderr,"Warning: found %d %s files for module \"%s\"\n",
+ no_of_matches, suffix_to_report, module_name);
+ break;
+ case 0:
+ {
+ char disaster_msg[MODNAME_SIZE+1000];
+ sprintf(disaster_msg,"can't find interface (%s) file for module \"%s\"%s",
+ suffix_to_report, module_name,
+ (strncmp(module_name, "PreludeGlaIO", 12) == 0)
+ ? "\n(The PreludeGlaIO interface no longer exists);"
+ :(
+ (strncmp(module_name, "PreludePrimIO", 13) == 0)
+ ? "\n(The PreludePrimIO interface no longer exists -- just use PreludeGlaST);"
+ :(
+ (strncmp(module_name, "Prelude", 7) == 0)
+ ? "\n(Perhaps you forgot a `-fglasgow-exts' flag?);"
+ : ""
+ )));
+ hsperror(disaster_msg);
+ break;
+ }
+ case 1:
+ /* Everything is fine */
+ break;
+ }
+}
--- /dev/null
+/*
+ * Infix operator stuff -- modified from LML
+ */
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "hsparser.tab.h"
+#include "constants.h"
+#include "utils.h"
+
+static struct infix {
+ char *imod;
+ char *iop;
+ short thismod;
+ short unqualok;
+ short ifixity;
+ short iprecedence;
+} infixtab[MAX_INFIX];
+
+static int ninfix = 0;
+
+void
+makeinfix(opid, fixity, precedence, modid, imported,
+ withas, impmodid, impasid, withqual,
+ withspec, withhiding, importspec)
+ id opid;
+ int fixity, precedence;
+ long imported, withas, withqual, withspec, withhiding;
+ id modid, impmodid, impasid;
+ list importspec;
+/*
+ ToDo: Throw away infix operator if hidden by importspec!
+*/
+{
+ int i;
+ char *op = id_to_string(opid);
+ char *mod = id_to_string(imported ? (withas ? impasid : impmodid) : modid);
+ short thismod = ! imported;
+ short unqualok = ! (imported && withqual);
+
+ for(i=0; i < ninfix; ++i)
+ {
+ if(strcmp(op,infixtab[i].iop)==0 &&
+ strcmp(mod,infixtab[i].imod)==0 &&
+ unqualok==infixtab[i].unqualok)
+ {
+ /* Allow duplicate definitions if they are identical */
+ if (infixtab[i].ifixity==fixity &&
+ infixtab[i].iprecedence==precedence)
+ {
+ return;
+ }
+
+ /* Allow local definition to override an import */
+ else if(thismod && !infixtab[i].thismod)
+ {
+ /*continue*/
+ }
+
+ else
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"%s.%s %s already declared to be %s %d\n",
+ mod, op, unqualok ? "(unqualified)" : "(qualified)",
+ infixstr(infixtab[i].ifixity),
+ infixtab[i].iprecedence);
+ hsperror(errbuf);
+ }
+ }
+ }
+
+ if (ninfix >= MAX_INFIX) {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"Too many Infix identifiers (> %d)",MAX_INFIX);
+ hsperror(errbuf);
+ }
+
+#ifdef HSP_DEBUG
+ fprintf(stderr,"makeinfix: %s.%s, fixity=%d prec=%d\n",mod,op,infixint(fixity),precedence);
+#endif
+ infixtab[ninfix].imod = mod;
+ infixtab[ninfix].iop = op;
+ infixtab[ninfix].thismod = thismod;
+ infixtab[ninfix].unqualok = unqualok;
+ infixtab[ninfix].ifixity = fixity;
+ infixtab[ninfix].iprecedence = precedence;
+ ninfix++;
+}
+
+struct infix *
+infixlookup(name)
+ qid name;
+{
+ int i;
+ struct infix *found = NULL;
+ char *op = qid_to_string(name);
+ char *mod = qid_to_mod(name);
+ short unqual = mod == NULL;
+
+ for(i = 0; i < ninfix; i++)
+ {
+ if(strcmp(op,infixtab[i].iop)==0 &&
+ ( (unqual && infixtab[i].unqualok) ||
+ (!unqual && strcmp(mod,infixtab[i].imod)==0)
+ ))
+ {
+ if (! found)
+ {
+ /* first find */
+ found = infixtab+i;
+ }
+ else if (found && ! found->thismod && infixtab[i].thismod)
+ {
+ /* new find for this module; overrides */
+ found = infixtab+i;
+ }
+ else if (found && found->thismod && ! infixtab[i].thismod)
+ {
+ /* prev find for this module */
+ }
+ else if (found->ifixity == infixtab[i].ifixity &&
+ found->iprecedence == infixtab[i].iprecedence)
+ {
+ /* finds are identical */
+ }
+ else
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"conflicting infix declarations for %s.%s\n %s.%s %s (%s,%d) and %s.%s %s (%s,%d)\n",
+ qid_to_pmod(name), op,
+ found->imod, found->iop, found->unqualok ? "(unqualified)" : "(qualified)",
+ infixstr(found->ifixity),found->iprecedence,
+ infixtab[i].imod, infixtab[i].iop, infixtab[i].unqualok ? "(unqualified)" : "(qualified)",
+ infixstr(infixtab[i].ifixity),infixtab[i].iprecedence);
+ hsperror(errbuf);
+
+ }
+ }
+ }
+
+#ifdef HSP_DEBUG
+ fprintf(stderr,"infixlookup: %s.%s = fixity=%d prec=%d\n",qid_to_pmod(name),op,infixint(pfixity(found)),pprecedence(found));
+#endif
+
+ return(found);
+}
+
+int
+pfixity(ip)
+ struct infix *ip;
+{
+ return(ip == NULL? INFIXL: ip->ifixity);
+}
+
+int
+pprecedence(ip)
+ struct infix *ip;
+{
+ return(ip == NULL? 9: ip->iprecedence);
+}
+
+char *
+infixstr(n)
+ int n;
+{
+ switch(n) {
+ case INFIXL:
+ return "infixl";
+
+ case INFIXR:
+ return "infixr";
+
+ case INFIX:
+ return "infix";
+
+ default:
+ hsperror("infixstr");
+ }
+}
+
+long
+infixint(n)
+ int n;
+{
+ switch(n) {
+ case INFIXL:
+ return -1;
+
+ case INFIX:
+ return 0;
+
+ case INFIXR:
+ return 1;
+
+ default:
+ hsperror("infixint");
+ }
+}
+
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_list where
+import Ubiq -- debugging consistency check
+import UgenUtil
+%}}
+type list;
+ lcons : < lhd : VOID_STAR;
+ ltl : list; >;
+ lnil : <>;
+end;
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_literal where
+import Ubiq -- debugging consistency check
+import UgenUtil
+%}}
+type literal;
+ integer : < ginteger : stringId; >;
+ intprim : < gintprim : stringId; >;
+ floatr : < gfloatr : stringId; >;
+ doubleprim : < gdoubleprim : stringId; >;
+ floatprim : < gfloatprim : stringId; >;
+ charr : < gchar : hstring; >;
+ charprim : < gcharprim : hstring; >;
+ string : < gstring : hstring; >;
+ stringprim : < gstringprim : hstring; >;
+ clitlit : < gclitlit : stringId;
+ gclitlit_kind : stringId; >;
+ norepi : < gnorepi : stringId; >;
+ norepr : < gnorepr_n : stringId;
+ gnorepr_d : stringId; >;
+ noreps : < gnoreps : hstring; >;
+end;
--- /dev/null
+/* This is the "top-level" file for the *standalone* hsp parser.
+ See also hsclink.c. (WDP 94/10)
+*/
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+/*OLD:static char *progname;*/ /* The name of the program. */
+
+
+/**********************************************************************
+* *
+* *
+* The main program *
+* *
+* *
+**********************************************************************/
+
+int
+main(int argc, char **argv)
+{
+ Lnil = mklnil(); /* The null list -- used in lsing, etc. */
+
+ process_args(argc,argv);
+
+ hash_init();
+
+#ifdef HSP_DEBUG
+ fprintf(stderr,"input_file_dir=%s\n",input_file_dir);
+#endif
+
+ yyinit();
+
+ if(yyparse() == 0 && !etags)
+ {
+ /* No syntax errors. */
+ pprogram(root);
+ printf("\n");
+ exit(0);
+ }
+ else if(etags)
+ {
+ exit(0);
+ }
+ else
+ {
+ /* There was a syntax error. */
+ printf("\n");
+ exit(1);
+ }
+}
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_maybe where
+import Ubiq -- debugging consistency check
+import UgenUtil
+%}}
+type maybe;
+ nothing : <> ;
+ just : < gthing : VOID_STAR; > ;
+end;
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_pbinding where
+import Ubiq -- debugging consistency check
+import UgenUtil
+
+import U_constr ( U_constr ) -- interface only
+import U_binding
+import U_coresyn ( U_coresyn ) -- ditto
+import U_hpragma ( U_hpragma ) -- ditto
+import U_list
+import U_literal ( U_literal ) -- ditto
+import U_maybe ( U_maybe ) -- ditto
+import U_qid
+import U_tree
+import U_ttype ( U_ttype ) -- ditto
+%}}
+type pbinding;
+ pgrhs : < ggpat : tree;
+ ggdexprs : pbinding;
+ ggbind : binding;
+ ggfuncname : qid;
+ ggline : long; >;
+
+ pnoguards : < gpnoguard : tree; >;
+ pguards : < gpguards : list; >;
+ pgdexp : < gpguard : tree;
+ gpexp : tree; >;
+end;
--- /dev/null
+/**********************************************************************
+* *
+* *
+* Syntax Tree Printing Routines *
+* *
+* *
+**********************************************************************/
+
+
+#define COMPACT TRUE /* No spaces in output -- #undef this for debugging */
+
+
+#include <stdio.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+/* fwd decls, necessary and otherwise */
+static void pbool PROTO( (BOOLEAN) );
+static void pconstr PROTO( (constr) );
+static void pcoresyn PROTO((coresyn));
+static void pentid PROTO( (entidt) );
+static void pgrhses PROTO( (list) );
+static void pid PROTO( (id) );
+static void plist PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
+static void pmaybe PROTO( (void (*)(), maybe) );
+static void pmaybe_list PROTO( (void (*)(), maybe) );
+static void ppbinding PROTO((pbinding));
+static void ppragma PROTO( (hpragma) );
+static void pqid PROTO( (qid) );
+static void prbind PROTO( (binding) );
+static void pstr PROTO( (char *) );
+static void ptree PROTO( (tree) );
+static void pttype PROTO( (ttype) );
+
+extern char *input_filename;
+extern BOOLEAN hashIds;
+
+/* How to print tags */
+
+#if COMPACT
+#define PUTTAG(c) putchar(c);
+#define PUTTAGSTR(s) printf("%s",(s));
+#else
+#define PUTTAG(c) putchar(c); \
+ putchar(' ');
+#define PUTTAGSTR(s) printf("%s",(s)); \
+ putchar(' ');
+#endif
+
+
+/* Performs a post order walk of the tree
+ to print it.
+*/
+
+void
+pprogram(t)
+ tree t;
+{
+ print_hash_table();
+ ptree(t);
+}
+
+/* print_string: we must escape \t and \\, as described in
+ char/string lexer comments. (WDP 94/11)
+*/
+static void
+print_string(hstring str)
+{
+ char *gs;
+ char c;
+ int i, str_length;
+
+ putchar('#');
+ str_length = str->len;
+ gs = str->bytes;
+
+ for (i = 0; i < str_length; i++) {
+ c = gs[i];
+ if ( c == '\t' ) {
+ putchar('\\');
+ putchar('t');
+ } else if ( c == '\\' ) {
+ putchar('\\');
+ putchar('\\');
+ } else {
+ putchar(gs[i]);
+ }
+ }
+ putchar('\t');
+}
+
+static int
+get_character(hstring str)
+{
+ int c = (int)((str->bytes)[0]);
+
+ if (str->len != 1) { /* ToDo: assert */
+ fprintf(stderr, "get_character: length != 1? (%ld: %s)\n", str->len, str->bytes);
+ }
+
+ if (c < 0) {
+ c += 256; /* "This is not a hack" -- KH */
+ }
+
+ return(c);
+}
+
+static void
+pliteral(literal t)
+{
+ switch(tliteral(t)) {
+ case integer:
+ PUTTAG('4');
+ pstr(ginteger(t));
+ break;
+ case intprim:
+ PUTTAG('H');
+ pstr(gintprim(t));
+ break;
+ case floatr:
+ PUTTAG('F');
+ pstr(gfloatr(t));
+ break;
+ case doubleprim:
+ PUTTAG('J');
+ pstr(gdoubleprim(t));
+ break;
+ case floatprim:
+ PUTTAG('K');
+ pstr(gfloatprim(t));
+ break;
+ case charr:
+ PUTTAG('C');
+ /* Changed %d to %u, since negative chars
+ make little sense -- KH @ 16/4/91
+ */
+ printf("#%u\t", get_character(gchar(t)));
+ break;
+ case charprim:
+ PUTTAG('P');
+ printf("#%u\t", get_character(gcharprim(t)));
+ break;
+ case string:
+ PUTTAG('S');
+ print_string(gstring(t));
+ break;
+ case stringprim:
+ PUTTAG('V');
+ print_string(gstringprim(t));
+ break;
+ case clitlit:
+ PUTTAG('Y');
+ pstr(gclitlit(t));
+ pstr(gclitlit_kind(t));
+ break;
+
+ case norepi:
+ PUTTAG('I');
+ pstr(gnorepi(t));
+ break;
+ case norepr:
+ PUTTAG('R');
+ pstr(gnorepr_n(t));
+ pstr(gnorepr_d(t));
+ break;
+ case noreps:
+ PUTTAG('s');
+ print_string(gnoreps(t));
+ break;
+ default:
+ error("Bad pliteral");
+ }
+}
+
+static void
+ptree(t)
+ tree t;
+{
+again:
+ switch(ttree(t)) {
+ case par: t = gpare(t); goto again;
+ case hmodule:
+ PUTTAG('M');
+ printf("#%lu\t",ghmodline(t));
+ pid(ghname(t));
+ pstr(input_filename);
+ prbind(ghmodlist(t));
+ /* pfixes(); */
+ plist(prbind, ghimplist(t));
+ pmaybe_list(pentid, ghexplist(t));
+ break;
+ case ident:
+ PUTTAG('i');
+ pqid(gident(t));
+ break;
+ case lit:
+ PUTTAG('C');
+ pliteral(glit(t));
+ break;
+
+ case ap:
+ PUTTAG('a');
+ ptree(gfun(t));
+ ptree(garg(t));
+ break;
+ case infixap:
+ PUTTAG('@');
+ pqid(ginffun(t));
+ ptree(ginfarg1(t));
+ ptree(ginfarg2(t));
+ break;
+ case lambda:
+ PUTTAG('l');
+ printf("#%lu\t",glamline(t));
+ plist(ptree,glampats(t));
+ ptree(glamexpr(t));
+ break;
+
+ case let:
+ PUTTAG('E');
+ prbind(gletvdefs(t));
+ ptree(gletvexpr(t));
+ break;
+ case casee:
+ PUTTAG('c');
+ ptree(gcaseexpr(t));
+ plist(ppbinding, gcasebody(t));
+ break;
+ case ife:
+ PUTTAG('b');
+ ptree(gifpred(t));
+ ptree(gifthen(t));
+ ptree(gifelse(t));
+ break;
+ /* case doe: */
+ /* case dobind: */
+ /* case doexp: */
+ /* case seqlet: */
+ /* case record: */
+ /* case rupdate: */
+ /* case rbind: */
+
+ case as:
+ PUTTAG('s');
+ pqid(gasid(t));
+ ptree(gase(t));
+ break;
+ case lazyp:
+ PUTTAG('~');
+ ptree(glazyp(t));
+ break;
+ case wildp:
+ PUTTAG('_');
+ break;
+
+ case restr:
+ PUTTAG('R');
+ ptree(grestre(t));
+ pttype(grestrt(t));
+ break;
+ case tuple:
+ PUTTAG(',');
+ plist(ptree,gtuplelist(t));
+ break;
+ case llist:
+ PUTTAG(':');
+ plist(ptree,gllist(t));
+ break;
+ case eenum:
+ PUTTAG('.');
+ ptree(gefrom(t));
+ pmaybe(ptree,gestep(t));
+ pmaybe(ptree,geto(t));
+ break;
+ case comprh:
+ PUTTAG('Z');
+ ptree(gcexp(t));
+ plist(ptree,gcquals(t));
+ break;
+ case qual:
+ PUTTAG('G');
+ ptree(gqpat(t));
+ ptree(gqexp(t));
+ break;
+ case guard:
+ PUTTAG('g');
+ ptree(ggexp(t));
+ break;
+ case lsection:
+ PUTTAG('(');
+ ptree(glsexp(t));
+ pqid(glsop(t));
+ break;
+ case rsection:
+ PUTTAG(')');
+ pqid(grsop(t));
+ ptree(grsexp(t));
+ break;
+ case ccall:
+ PUTTAG('j');
+ pstr(gccid(t));
+ pstr(gccinfo(t));
+ plist(ptree,gccargs(t));
+ break;
+ case scc:
+ PUTTAG('k');
+ print_string(gsccid(t));
+ ptree(gsccexp(t));
+ break;
+ case negate:
+ PUTTAG('-');
+ ptree(gnexp(t));
+ break;
+ default:
+ error("Bad ptree");
+ }
+}
+
+static void
+plist(fun, l)
+ void (*fun)(/* NOT WORTH IT: void * */);
+ list l;
+{
+ if (tlist(l) == lnil) {
+ PUTTAG('N');
+ } else {
+ PUTTAG('L');
+ (*fun)(lhd(l));
+ plist(fun, ltl(l));
+ }
+}
+
+static void
+pmaybe(fun, m)
+ void (*fun)(/* NOT WORTH IT: void * */);
+ maybe m;
+{
+ if (tmaybe(m) == nothing) {
+ PUTTAG('N');
+ } else {
+ PUTTAG('J');
+ (*fun)(gthing(m));
+ }
+}
+
+static void
+pmaybe_list(fun, m)
+ void (*fun)(/* NOT WORTH IT: void * */);
+ maybe m;
+{
+ if (tmaybe(m) == nothing) {
+ PUTTAG('N');
+ } else {
+ PUTTAG('J');
+ plist(fun, gthing(m));
+ }
+}
+
+static void
+pid(i)
+ id i;
+{
+ if(hashIds)
+ printf("!%lu\t", hash_index(i));
+ else
+ printf("#%s\t", id_to_string(i));
+}
+
+static void
+pqid(i)
+ qid i;
+{
+ if(hashIds)
+ printf("!%lu\t", hash_index(qid_to_id(i)));
+ else
+ printf("#%s\t", qid_to_string(i));
+}
+
+static void
+pstr(i)
+ char *i;
+{
+ printf("#%s\t", i);
+}
+
+static void
+prbind(b)
+ binding b;
+{
+ switch(tbinding(b)) {
+ case tbind:
+ PUTTAG('t');
+ printf("#%lu\t",gtline(b));
+ plist(pttype, gtbindc(b));
+ pmaybe_list(pid, gtbindd(b));
+ pttype(gtbindid(b));
+ plist(pconstr, gtbindl(b));
+ ppragma(gtpragma(b));
+ break;
+ /* case ntbind: */
+ case nbind :
+ PUTTAG('n');
+ printf("#%lu\t",gnline(b));
+ pttype(gnbindid(b));
+ pttype(gnbindas(b));
+ break;
+ case pbind :
+ PUTTAG('p');
+ printf("#%lu\t",gpline(b));
+ plist(ppbinding, gpbindl(b));
+ break;
+ case fbind :
+ PUTTAG('f');
+ printf("#%lu\t",gfline(b));
+ plist(ppbinding, gfbindl(b));
+ break;
+ case abind :
+ PUTTAG('A');
+ prbind(gabindfst(b));
+ prbind(gabindsnd(b));
+ break;
+ case cbind :
+ PUTTAG('$');
+ printf("#%lu\t",gcline(b));
+ plist(pttype,gcbindc(b));
+ pttype(gcbindid(b));
+ prbind(gcbindw(b));
+ ppragma(gcpragma(b));
+ break;
+ case ibind :
+ PUTTAG('%');
+ printf("#%lu\t",giline(b));
+ plist(pttype,gibindc(b));
+ pqid(gibindid(b));
+ pttype(gibindi(b));
+ prbind(gibindw(b));
+ ppragma(gipragma(b));
+ break;
+ case dbind :
+ PUTTAG('D');
+ printf("#%lu\t",gdline(b));
+ plist(pttype,gdbindts(b));
+ break;
+
+ /* signature(-like) things, including user pragmas */
+ case sbind :
+ PUTTAGSTR("St");
+ printf("#%lu\t",gsline(b));
+ plist(pqid,gsbindids(b));
+ pttype(gsbindid(b));
+ ppragma(gspragma(b));
+ break;
+
+ case vspec_uprag:
+ PUTTAGSTR("Ss");
+ printf("#%lu\t",gvspec_line(b));
+ pqid(gvspec_id(b));
+ plist(pttype,gvspec_tys(b));
+ break;
+ case ispec_uprag:
+ PUTTAGSTR("SS");
+ printf("#%lu\t",gispec_line(b));
+ pqid(gispec_clas(b));
+ pttype(gispec_ty(b));
+ break;
+ case inline_uprag:
+ PUTTAGSTR("Si");
+ printf("#%lu\t",ginline_line(b));
+ pqid(ginline_id(b));
+ break;
+ case deforest_uprag:
+ PUTTAGSTR("Sd");
+ printf("#%lu\t",gdeforest_line(b));
+ pqid(gdeforest_id(b));
+ break;
+ case magicuf_uprag:
+ PUTTAGSTR("Su");
+ printf("#%lu\t",gmagicuf_line(b));
+ pqid(gmagicuf_id(b));
+ pid(gmagicuf_str(b));
+ break;
+ case dspec_uprag:
+ PUTTAGSTR("Sd");
+ printf("#%lu\t",gdspec_line(b));
+ pqid(gdspec_id(b));
+ plist(pttype,gdspec_tys(b));
+ break;
+
+ /* end of signature(-like) things */
+
+ case mbind:
+ PUTTAG('7');
+ printf("#%lu\t",gmline(b));
+ pid(gmbindmodn(b));
+ plist(pentid,gmbindimp(b));
+ break;
+ case import:
+ PUTTAG('e');
+ printf("#%lu\t",gibindline(b));
+ pid(gibindfile(b));
+ pid(gibindmod(b));
+ /* plist(pentid,giebindexp(b)); ??? */
+ /* prbind(giebinddef(b)); ???? */
+ break;
+ case nullbind :
+ PUTTAG('B');
+ break;
+ default : error("Bad prbind");
+ break;
+ }
+}
+
+static void
+pttype(t)
+ ttype t;
+{
+ switch (tttype(t)) {
+ case tname : PUTTAG('T');
+ pqid(gtypeid(t));
+ break;
+ case namedtvar : PUTTAG('y');
+ pid(gnamedtvar(t));
+ break;
+ case tllist : PUTTAG(':');
+ pttype(gtlist(t));
+ break;
+ case ttuple : PUTTAG(',');
+ plist(pttype,gttuple(t));
+ break;
+ case tfun : PUTTAG('>');
+ pttype(gtin(t));
+ pttype(gtout(t));
+ break;
+ case tapp : PUTTAG('@');
+ pttype(gtapp(t));
+ pttype(gtarg(t));
+ break;
+ case tbang : PUTTAG('!');
+ pttype(gtbang(t));
+ break;
+ case context : PUTTAG('3');
+ plist(pttype,gtcontextl(t));
+ pttype(gtcontextt(t));
+ break;
+
+ case unidict : PUTTAGSTR("2A");
+ pqid(gunidict_clas(t));
+ pttype(gunidict_ty(t));
+ break;
+ case unityvartemplate : PUTTAGSTR("2B");
+ pid(gunityvartemplate(t));
+ break;
+ case uniforall : PUTTAGSTR("2C");
+ plist(pid,guniforall_tv(t));
+ pttype(guniforall_ty(t));
+ break;
+
+ default : error("bad pttype");
+ }
+}
+
+static void
+pconstr(a)
+ constr a;
+{
+ switch (tconstr(a)) {
+ case constrpre :
+ PUTTAG('1');
+ printf("#%lu\t",gconcline(a));
+ pqid(gconcid(a));
+ plist(pttype, gconctypel(a));
+ break;
+ case constrinf :
+ PUTTAG('2');
+ printf("#%lu\t",gconiline(a));
+ pqid(gconiop(a));
+ pttype(gconity1(a));
+ pttype(gconity2(a));
+ break;
+
+ default : fprintf(stderr, "Bad tag in abstree %d\n", tconstr(a));
+ exit(1);
+ }
+}
+
+
+static void
+pentid(i)
+ entidt i;
+{
+ switch (tentidt(i)) {
+ case entid : PUTTAG('x');
+ pqid(gentid(i));
+ break;
+ case enttype : PUTTAG('X');
+ pqid(gtentid(i));
+ break;
+ case enttypeall : PUTTAG('z');
+ pqid(gaentid(i));
+ break;
+ case enttypenamed:PUTTAG('8');
+ pqid(gnentid(i));
+ plist(pqid,gnentnames(i));
+ break;
+ case entmod : PUTTAG('m');
+ pid(gmentid(i));
+ break;
+ default :
+ error("Bad pentid");
+ }
+}
+
+
+static void
+ppbinding(p)
+ pbinding p;
+{
+ switch(tpbinding(p)) {
+ case pgrhs : PUTTAG('W');
+ printf("#%lu\t",ggline(p));
+ pqid(ggfuncname(p));
+ ptree(ggpat(p));
+ plist(pgrhses,ggdexprs(p));
+ prbind(ggbind(p));
+ break;
+ default :
+ error("Bad pbinding");
+ }
+}
+
+
+static void
+pgrhses(l)
+ list l;
+{
+ ptree(lhd(l)); /* Guard */
+ ptree(lhd(ltl(l))); /* Expression */
+}
+
+static void
+ppragma(p)
+ hpragma p;
+{
+ switch(thpragma(p)) {
+ case no_pragma: PUTTAGSTR("PN");
+ break;
+ case idata_pragma: PUTTAGSTR("Pd");
+ plist(pconstr, gprag_data_constrs(p));
+ plist(ppragma, gprag_data_specs(p));
+ break;
+ case itype_pragma: PUTTAGSTR("Pt");
+ break;
+ case iclas_pragma: PUTTAGSTR("Pc");
+ plist(ppragma, gprag_clas(p));
+ break;
+ case iclasop_pragma: PUTTAGSTR("Po");
+ ppragma(gprag_dsel(p));
+ ppragma(gprag_defm(p));
+ break;
+
+ case iinst_simpl_pragma: PUTTAGSTR("Pis");
+ pid(gprag_imod_simpl(p));
+ ppragma(gprag_dfun_simpl(p));
+ break;
+ case iinst_const_pragma: PUTTAGSTR("Pic");
+ pid(gprag_imod_const(p));
+ ppragma(gprag_dfun_const(p));
+ plist(ppragma, gprag_constms(p));
+ break;
+
+ case igen_pragma: PUTTAGSTR("Pg");
+ ppragma(gprag_arity(p));
+ ppragma(gprag_update(p));
+ ppragma(gprag_deforest(p));
+ ppragma(gprag_strictness(p));
+ ppragma(gprag_unfolding(p));
+ plist(ppragma, gprag_specs(p));
+ break;
+ case iarity_pragma: PUTTAGSTR("PA");
+ pid(gprag_arity_val(p));
+ break;
+ case iupdate_pragma: PUTTAGSTR("Pu");
+ pid(gprag_update_val(p));
+ break;
+ case ideforest_pragma: PUTTAGSTR("PD");
+ break;
+ case istrictness_pragma: PUTTAGSTR("PS");
+ print_string(gprag_strict_spec(p));
+ ppragma(gprag_strict_wrkr(p));
+ break;
+ case imagic_unfolding_pragma: PUTTAGSTR("PM");
+ pid(gprag_magic_str(p));
+ break;
+
+ case iunfolding_pragma: PUTTAGSTR("PU");
+ ppragma(gprag_unfold_guide(p));
+ pcoresyn(gprag_unfold_core(p));
+ break;
+
+ case iunfold_always: PUTTAGSTR("Px");
+ break;
+ case iunfold_if_args: PUTTAGSTR("Py");
+ pid(gprag_unfold_if_t_args(p));
+ pid(gprag_unfold_if_v_args(p));
+ pid(gprag_unfold_if_con_args(p));
+ pid(gprag_unfold_if_size(p));
+ break;
+
+ case iname_pragma_pr: PUTTAGSTR("P1");
+ pid(gprag_name_pr1(p));
+ ppragma(gprag_name_pr2(p));
+ break;
+ case itype_pragma_pr: PUTTAGSTR("P2");
+ plist(pttype, gprag_type_pr1(p));
+ pid(gprag_type_pr2(p));
+ ppragma(gprag_type_pr3(p));
+ break;
+
+ case idata_pragma_4s: PUTTAGSTR("P4");
+ plist(pttype, gprag_data_spec(p));
+ break;
+
+ default: error("Bad Pragma");
+ }
+}
+
+static void
+pbool(b)
+ BOOLEAN b;
+{
+ if (b) {
+ putchar('T');
+ } else {
+ putchar('F');
+ }
+}
+
+static void
+pcoresyn(p)
+ coresyn p;
+{
+ switch(tcoresyn(p)) {
+ case cobinder: PUTTAGSTR("Fa");
+ pid(gcobinder_v(p));
+ pttype(gcobinder_ty(p));
+ break;
+
+ case colit: PUTTAGSTR("Fb");
+ pliteral(gcolit(p));
+ break;
+ case colocal: PUTTAGSTR("Fc");
+ pcoresyn(gcolocal_v(p));
+ break;
+
+ case cononrec: PUTTAGSTR("Fd");
+ pcoresyn(gcononrec_b(p));
+ pcoresyn(gcononrec_rhs(p));
+ break;
+ case corec: PUTTAGSTR("Fe");
+ plist(pcoresyn,gcorec(p));
+ break;
+ case corec_pair: PUTTAGSTR("Ff");
+ pcoresyn(gcorec_b(p));
+ pcoresyn(gcorec_rhs(p));
+ break;
+
+ case covar: PUTTAGSTR("Fg");
+ pcoresyn(gcovar(p));
+ break;
+ case coliteral: PUTTAGSTR("Fh");
+ pliteral(gcoliteral(p));
+ break;
+ case cocon: PUTTAGSTR("Fi");
+ pcoresyn(gcocon_con(p));
+ plist(pttype, gcocon_tys(p));
+ plist(pcoresyn, gcocon_args(p));
+ break;
+ case coprim: PUTTAGSTR("Fj");
+ pcoresyn(gcoprim_op(p));
+ plist(pttype, gcoprim_tys(p));
+ plist(pcoresyn, gcoprim_args(p));
+ break;
+ case colam: PUTTAGSTR("Fk");
+ plist(pcoresyn, gcolam_vars(p));
+ pcoresyn(gcolam_body(p));
+ break;
+ case cotylam: PUTTAGSTR("Fl");
+ plist(pid, gcotylam_tvs(p));
+ pcoresyn(gcotylam_body(p));
+ break;
+ case coapp: PUTTAGSTR("Fm");
+ pcoresyn(gcoapp_fun(p));
+ plist(pcoresyn, gcoapp_args(p));
+ break;
+ case cotyapp: PUTTAGSTR("Fn");
+ pcoresyn(gcotyapp_e(p));
+ pttype(gcotyapp_t(p));
+ break;
+ case cocase: PUTTAGSTR("Fo");
+ pcoresyn(gcocase_s(p));
+ pcoresyn(gcocase_alts(p));
+ break;
+ case colet: PUTTAGSTR("Fp");
+ pcoresyn(gcolet_bind(p));
+ pcoresyn(gcolet_body(p));
+ break;
+ case coscc: PUTTAGSTR("Fz"); /* out of order! */
+ pcoresyn(gcoscc_scc(p));
+ pcoresyn(gcoscc_body(p));
+ break;
+
+ case coalg_alts: PUTTAGSTR("Fq");
+ plist(pcoresyn, gcoalg_alts(p));
+ pcoresyn(gcoalg_deflt(p));
+ break;
+ case coalg_alt: PUTTAGSTR("Fr");
+ pcoresyn(gcoalg_con(p));
+ plist(pcoresyn, gcoalg_bs(p));
+ pcoresyn(gcoalg_rhs(p));
+ break;
+ case coprim_alts: PUTTAGSTR("Fs");
+ plist(pcoresyn, gcoprim_alts(p));
+ pcoresyn(gcoprim_deflt(p));
+ break;
+ case coprim_alt: PUTTAGSTR("Ft");
+ pliteral(gcoprim_lit(p));
+ pcoresyn(gcoprim_rhs(p));
+ break;
+ case conodeflt: PUTTAGSTR("Fu");
+ break;
+ case cobinddeflt: PUTTAGSTR("Fv");
+ pcoresyn(gcobinddeflt_v(p));
+ pcoresyn(gcobinddeflt_rhs(p));
+ break;
+
+ case co_primop: PUTTAGSTR("Fw");
+ pid(gco_primop(p));
+ break;
+ case co_ccall: PUTTAGSTR("Fx");
+ pbool(gco_ccall_may_gc(p));
+ pid(gco_ccall(p));
+ plist(pttype, gco_ccall_arg_tys(p));
+ pttype(gco_ccall_res_ty(p));
+ break;
+ case co_casm: PUTTAGSTR("Fy");
+ pbool(gco_casm_may_gc(p));
+ pliteral(gco_casm(p));
+ plist(pttype, gco_casm_arg_tys(p));
+ pttype(gco_casm_res_ty(p));
+ break;
+
+ /* Cost-centre stuff */
+ case co_preludedictscc: PUTTAGSTR("F?a");
+ pcoresyn(gco_preludedictscc_dupd(p));
+ break;
+ case co_alldictscc: PUTTAGSTR("F?b");
+ print_string(gco_alldictscc_m(p));
+ print_string(gco_alldictscc_g(p));
+ pcoresyn(gco_alldictscc_dupd(p));
+ break;
+ case co_usercc: PUTTAGSTR("F?c");
+ print_string(gco_usercc_n(p));
+ print_string(gco_usercc_m(p));
+ print_string(gco_usercc_g(p));
+ pcoresyn(gco_usercc_dupd(p));
+ pcoresyn(gco_usercc_cafd(p));
+ break;
+ case co_autocc: PUTTAGSTR("F?d");
+ pcoresyn(gco_autocc_i(p));
+ print_string(gco_autocc_m(p));
+ print_string(gco_autocc_g(p));
+ pcoresyn(gco_autocc_dupd(p));
+ pcoresyn(gco_autocc_cafd(p));
+ break;
+ case co_dictcc: PUTTAGSTR("F?e");
+ pcoresyn(gco_dictcc_i(p));
+ print_string(gco_dictcc_m(p));
+ print_string(gco_dictcc_g(p));
+ pcoresyn(gco_dictcc_dupd(p));
+ pcoresyn(gco_dictcc_cafd(p));
+ break;
+
+ case co_scc_noncaf: PUTTAGSTR("F?f");
+ break;
+ case co_scc_caf: PUTTAGSTR("F?g");
+ break;
+ case co_scc_nondupd: PUTTAGSTR("F?h");
+ break;
+ case co_scc_dupd: PUTTAGSTR("F?i");
+ break;
+
+ /* Id stuff */
+ case co_id: PUTTAGSTR("F1");
+ pid(gco_id(p));
+ break;
+ case co_orig_id: PUTTAGSTR("F9");
+ pid(gco_orig_id_m(p));
+ pid(gco_orig_id_n(p));
+ break;
+ case co_sdselid: PUTTAGSTR("F2");
+ pid(gco_sdselid_c(p));
+ pid(gco_sdselid_sc(p));
+ break;
+ case co_classopid: PUTTAGSTR("F3");
+ pid(gco_classopid_c(p));
+ pid(gco_classopid_o(p));
+ break;
+ case co_defmid: PUTTAGSTR("F4");
+ pid(gco_defmid_c(p));
+ pid(gco_defmid_op(p));
+ break;
+ case co_dfunid: PUTTAGSTR("F5");
+ pid(gco_dfunid_c(p));
+ pttype(gco_dfunid_ty(p));
+ break;
+ case co_constmid: PUTTAGSTR("F6");
+ pid(gco_constmid_c(p));
+ pid(gco_constmid_op(p));
+ pttype(gco_constmid_ty(p));
+ break;
+ case co_specid: PUTTAGSTR("F7");
+ pcoresyn(gco_specid_un(p));
+ plist(pttype,gco_specid_tys(p));
+ break;
+ case co_wrkrid: PUTTAGSTR("F8");
+ pcoresyn(gco_wrkrid_un(p));
+ break;
+ /* more to come?? */
+
+ default : error("Bad Core syntax");
+ }
+}
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_qid where
+import Ubiq -- debugging consistency check
+import UgenUtil
+%}}
+type qid;
+ noqual : < gnoqual : stringId; >;
+ aqual : < gqualmod : stringId;
+ gqualname : stringId; >;
+ gid : < ggid : long;
+ gidname : stringId; >;
+end;
+
--- /dev/null
+/**********************************************************************
+* *
+* *
+* Syntax-related Utility Functions *
+* *
+* *
+**********************************************************************/
+
+#include <stdio.h>
+#include <ctype.h>
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+#include "tree.h"
+
+#include "hsparser.tab.h"
+
+/* Imported values */
+extern short icontexts;
+extern list Lnil;
+extern unsigned endlineno, startlineno;
+extern BOOLEAN hashIds, etags;
+
+/* Forward Declarations */
+
+char *ineg PROTO((char *));
+static tree unparen PROTO((tree));
+static void is_conapp_patt PROTO((int, tree, tree));
+static void rearrangeprec PROTO((tree, tree));
+static void error_if_expr_wanted PROTO((int, char *));
+static void error_if_patt_wanted PROTO((int, char *));
+
+qid fns[MAX_CONTEXTS] = { NULL };
+BOOLEAN samefn[MAX_CONTEXTS] = { FALSE };
+tree prevpatt[MAX_CONTEXTS] = { NULL };
+
+BOOLEAN inpat = FALSE;
+
+static BOOLEAN checkorder2 PROTO((binding, BOOLEAN));
+static BOOLEAN checksig PROTO((BOOLEAN, binding));
+
+/*
+ check infix value in range 0..9
+*/
+
+
+int
+checkfixity(vals)
+ char *vals;
+{
+ int value;
+ sscanf(vals,"%d",&value);
+
+ if (value < 0 || value > 9)
+ {
+ int oldvalue = value;
+ value = value < 0 ? 0 : 9;
+ fprintf(stderr,"Precedence must be between 0 and 9 (value given: %d, changed to %d)\n",
+ oldvalue,value);
+ }
+ return(value);
+}
+
+
+/*
+ Check Previous Pattern usage
+*/
+
+void
+checksamefn(fn)
+ qid fn;
+{
+ char *this = qid_to_string(fn);
+ char *was = (FN==NULL) ? NULL : qid_to_string(FN);
+
+ SAMEFN = (was != NULL && strcmp(this,was) == 0);
+
+ if(!SAMEFN && etags)
+#if 1/*etags*/
+ printf("%u\n",startlineno);
+#else
+ fprintf(stderr,"%u\tchecksamefn:%s\n",startlineno,this);
+#endif
+}
+
+
+void
+checkinpat()
+{
+ if(!inpat)
+ hsperror("pattern syntax used in expression");
+}
+
+/* ------------------------------------------------------------------------
+*/
+
+void
+expORpat(int wanted, tree e)
+{
+ switch(ttree(e))
+ {
+ case ident: /* a pattern or expr */
+ break;
+
+ case wildp:
+ error_if_expr_wanted(wanted, "wildcard in expression");
+ break;
+
+ case as:
+ error_if_expr_wanted(wanted, "`as'-pattern instead of an expression");
+ expORpat(wanted, gase(e));
+ break;
+
+ case lazyp:
+ error_if_expr_wanted(wanted, "irrefutable pattern instead of an expression");
+ expORpat(wanted, glazyp(e));
+ break;
+
+ case lit:
+ switch (tliteral(glit(e))) {
+ case integer:
+ case intprim:
+ case floatr:
+ case doubleprim:
+ case floatprim:
+ case string:
+ case stringprim:
+ case charr:
+ case charprim:
+ break; /* pattern or expr */
+
+ case clitlit:
+ error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
+
+ default: /* the others only occur in pragmas */
+ hsperror("not a valid literal pattern or expression");
+ }
+ break;
+
+ case negate:
+ { tree sub = gnexp(e);
+ if (ttree(sub) != lit) {
+ error_if_patt_wanted(wanted, "\"-\" applied to a non-literal");
+ } else {
+ literal l = glit(sub);
+
+ if (tliteral(l) != integer && tliteral(l) != floatr) {
+ error_if_patt_wanted(wanted, "\"-\" applied to a non-number");
+ }
+ }
+ expORpat(wanted, sub);
+ }
+ break;
+
+ case ap:
+ {
+ tree f = gfun(e);
+ tree a = garg(e);
+
+ is_conapp_patt(wanted, f, a); /* does nothing unless wanted == LEGIT_PATT */
+ expORpat(wanted, f);
+ expORpat(wanted, a);
+ }
+ break;
+
+ case infixap:
+ {
+ qid f = ginffun ((struct Sinfixap *)e);
+ tree a1 = ginfarg1((struct Sinfixap *)e);
+ tree a2 = ginfarg2((struct Sinfixap *)e);
+
+ expORpat(wanted, a1);
+ expORpat(wanted, a2);
+
+ if (wanted == LEGIT_PATT && !isconstr(qid_to_string(f)))
+ hsperror("variable application in pattern");
+ }
+ break;
+
+ case record:
+ {
+ list field;
+ for (field = grbinds(e); tlist(field) == lcons; field = ltl(field)) {
+ expORpat(wanted, lhd(field));
+ }
+ }
+ break;
+
+ case rbind:
+ if (tmaybe(grbindexp(e)) == just)
+ expORpat(wanted, gthing(grbindexp(e)));
+ break;
+
+ case tuple:
+ {
+ list tup;
+ for (tup = gtuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
+ expORpat(wanted, lhd(tup));
+ }
+ }
+ break;
+
+ case llist:
+ {
+ list l;
+ for (l = gllist(e); tlist(l) == lcons; l = ltl(l)) {
+ expORpat(wanted, lhd(l));
+ }
+ }
+ break;
+
+ case par: /* parenthesised */
+ expORpat(wanted, gpare(e));
+ break;
+
+ case restr:
+ case lambda:
+ case let:
+ case casee:
+ case ife:
+ case doe:
+ case ccall:
+ case scc:
+ case rupdate:
+ case comprh:
+ case eenum:
+ case lsection:
+ case rsection:
+ error_if_patt_wanted(wanted, "unexpected construct in a pattern");
+ break;
+
+ default:
+ hsperror("not a pattern or expression");
+ }
+}
+
+static void
+is_conapp_patt(int wanted, tree f, tree a)
+{
+ if (wanted == LEGIT_EXPR)
+ return; /* that was easy */
+
+ switch(ttree(f))
+ {
+ case ident:
+ if (isconstr(qid_to_string(gident(f))))
+ {
+ expORpat(wanted, a);
+ return;
+ }
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"not a constructor application -- %s",qid_to_string(gident(f)));
+ hsperror(errbuf);
+ }
+
+ case ap:
+ is_conapp_patt(wanted, gfun(f), garg(f));
+ expORpat(wanted, a);
+ return;
+
+ case par:
+ is_conapp_patt(wanted, gpare(f), a);
+ break;
+
+ case tuple:
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"tuple pattern `applied' to arguments (missing comma?)");
+ hsperror(errbuf);
+ }
+ break;
+
+ default:
+ hsperror("not a constructor application");
+ }
+}
+
+static void
+error_if_expr_wanted(int wanted, char *msg)
+{
+ if (wanted == LEGIT_EXPR)
+ hsperror(msg);
+}
+
+static void
+error_if_patt_wanted(int wanted, char *msg)
+{
+ if (wanted == LEGIT_PATT)
+ hsperror(msg);
+}
+
+/* ---------------------------------------------------------------------- */
+
+BOOLEAN /* return TRUE if LHS is a pattern */
+lhs_is_patt(tree e)
+{
+ switch(ttree(e))
+ {
+ case lit:
+ switch (tliteral(glit(e))) {
+ case integer:
+ case intprim:
+ case floatr:
+ case doubleprim:
+ case floatprim:
+ case string:
+ case charr:
+ case charprim:
+ case stringprim:
+ return TRUE;
+ default:
+ hsperror("Literal is not a valid LHS");
+ }
+
+ case wildp:
+ return TRUE;
+
+ case as:
+ case lazyp:
+ case llist:
+ case tuple:
+ case negate:
+ expORpat(LEGIT_PATT, e);
+ return TRUE;
+
+ case ident:
+ return(TRUE);
+ /* This change might break ap infixop below. BEWARE.
+ return (isconstr(qid_to_string(gident(e))));
+ */
+
+ case ap:
+ {
+ tree f = function(e);
+ tree a = garg(e); /* do not "unparen", otherwise the error
+ fromInteger ((x,y) {-no comma-} z)
+ will be missed.
+ */
+
+ /* definitions must have pattern arguments */
+ expORpat(LEGIT_PATT, a);
+
+ if(ttree(f) == ident)
+ return(isconstr(qid_to_string(gident(f))));
+
+ else if(ttree(f) == infixap)
+ return(lhs_is_patt(f));
+
+ else
+ hsperror("Not a legal pattern binding in LHS");
+ }
+
+ case infixap:
+ {
+ qid f = ginffun((struct Sinfixap *)e);
+ tree a1 = unparen(ginfarg1((struct Sinfixap *)e)),
+ a2 = unparen(ginfarg2((struct Sinfixap *)e));
+
+ /* definitions must have pattern arguments */
+ expORpat(LEGIT_PATT, a1);
+ expORpat(LEGIT_PATT, a2);
+
+ return(isconstr(qid_to_string(f)));
+ }
+
+ case par:
+ return(lhs_is_patt(gpare(e)));
+
+ /* Anything else must be an illegal LHS */
+ default:
+ hsperror("Not a valid LHS");
+ }
+
+ abort(); /* should never get here */
+ return(FALSE);
+}
+
+
+/*
+ Return the function at the root of a series of applications.
+*/
+
+tree
+function(e)
+ tree e;
+{
+ switch (ttree(e))
+ {
+ case ap:
+ expORpat(LEGIT_PATT, garg(e));
+ return(function(gfun(e)));
+
+ case par:
+ return(function(gpare(e)));
+
+ default:
+ return(e);
+ }
+}
+
+
+static tree
+unparen(e)
+ tree e;
+{
+ while (ttree(e) == par)
+ e = gpare(e);
+
+ return(e);
+}
+
+
+/*
+ Extend a function by adding a new definition to its list of bindings.
+*/
+
+void
+extendfn(bind,rule)
+binding bind;
+binding rule;
+{
+/* fprintf(stderr,"extending binding (%d)\n",tbinding(bind));*/
+ if(tbinding(bind) == abind)
+ bind = gabindsnd(bind);
+
+ if(tbinding(bind) == pbind)
+ gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule));
+ else if(tbinding(bind) == fbind)
+ gfbindl(bind) = lconc(gfbindl(bind), gfbindl(rule));
+ else
+ fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
+}
+
+/*
+
+ Precedence Parser for Haskell. By default operators are left-associative,
+ so it is only necessary to rearrange the parse tree where the new operator
+ has a greater precedence than the existing one, or where two operators have
+ the same precedence and are both right-associative. Error conditions are
+ handled.
+
+ Note: Prefix negation has the same precedence as infix minus.
+ The algorithm must thus take account of explicit negates.
+*/
+
+void
+precparse(tree t)
+{
+ if(ttree(t) == infixap)
+ {
+ tree left = ginfarg1(t);
+
+ if(ttree(left) == negate)
+ {
+ struct infix *ttabpos = infixlookup(ginffun(t));
+ struct infix *ntabpos = infixlookup(mknoqual(install_literal("-")));
+
+ if(pprecedence(ntabpos) < pprecedence(ttabpos))
+ {
+ /* (-x)*y ==> -(x*y) */
+ qid lop = ginffun(t);
+ tree arg1 = gnexp(left);
+ tree arg2 = ginfarg2(t);
+
+ t->tag = negate;
+ gnexp(t) = left;
+ gnxxx1(t) = NULL;
+ gnxxx2(t) = NULL;
+
+ left->tag = infixap;
+ ginffun(left) = lop;
+ ginfarg1(left) = arg1;
+ ginfarg2(left) = arg2;
+
+ precparse(left);
+ }
+ }
+
+ else if(ttree(left) == infixap)
+ {
+ struct infix *ttabpos = infixlookup(ginffun(t));
+ struct infix *lefttabpos = infixlookup(ginffun(left));
+
+ if(pprecedence(lefttabpos) < pprecedence(ttabpos))
+ rearrangeprec(left,t);
+
+ else if(pprecedence(lefttabpos) == pprecedence(ttabpos))
+ {
+ if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
+ rearrangeprec(left,t);
+
+ else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
+ /* SKIP */;
+
+ else
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"Cannot mix %s and %s in the same infix expression",
+ qid_to_string(ginffun(left)), qid_to_string(ginffun(t)));
+ hsperror(errbuf);
+ }
+ }
+ }
+ }
+}
+
+
+/*
+ Rearrange a tree to effectively insert an operator in the correct place.
+
+ x+y*z ==parsed== (x+y)*z ==> x+(y*z)
+
+ The recursive call to precparse ensures this filters down as necessary.
+*/
+
+static void
+rearrangeprec(tree left, tree t)
+{
+ qid top = ginffun(left);
+ qid lop = ginffun(t);
+ tree arg1 = ginfarg1(left);
+ tree arg2 = ginfarg2(left);
+ tree arg3 = ginfarg2(t);
+
+ ginffun(t) = top;
+ ginfarg1(t) = arg1;
+ ginfarg2(t) = left;
+
+ ginffun(left) = lop;
+ ginfarg1(left) = arg2;
+ ginfarg2(left) = arg3;
+
+ precparse(left);
+}
+
+pbinding
+createpat(guards,where)
+ pbinding guards;
+ binding where;
+{
+ qid func;
+
+ if(FN != NULL)
+ func = FN;
+ else
+ func = mknoqual(install_literal(""));
+
+ return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
+}
+
+char *
+ineg(i)
+ char *i;
+{
+ char *p = xmalloc(strlen(i)+2);
+
+ *p = '-';
+ strcpy(p+1,i);
+ return(p);
+}
+
+#if 0
+/* UNUSED: at the moment */
+void
+checkmodname(import,interface)
+ id import, interface;
+{
+ if(strcmp(import,interface) != 0)
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"interface name (%s) does not agree with import name (%s)",interface,import);
+ hsperror(errbuf);
+ }
+}
+#endif /* 0 */
+
+/*
+ Check the ordering of declarations in a cbody.
+ All signatures must appear before any declarations.
+*/
+
+void
+checkorder(decls)
+ binding decls;
+{
+ /* The ordering must be correct for a singleton */
+ if(tbinding(decls)!=abind)
+ return;
+
+ checkorder2(decls,TRUE);
+}
+
+static BOOLEAN
+checkorder2(decls,sigs)
+ binding decls;
+ BOOLEAN sigs;
+{
+ while(tbinding(decls)==abind)
+ {
+ /* Perform a left-traversal if necessary */
+ binding left = gabindfst(decls);
+ if(tbinding(left)==abind)
+ sigs = checkorder2(left,sigs);
+ else
+ sigs = checksig(sigs,left);
+ decls = gabindsnd(decls);
+ }
+
+ return(checksig(sigs,decls));
+}
+
+
+static BOOLEAN
+checksig(sig,decl)
+ BOOLEAN sig;
+ binding decl;
+{
+ BOOLEAN issig = tbinding(decl) == sbind || tbinding(decl) == nullbind;
+ if(!sig && issig)
+ hsperror("Signature appears after definition in class body");
+
+ return(issig);
+}
+
+
+/*
+ Check the last expression in a list of do statements.
+*/
+
+void
+checkdostmts(stmts)
+ list stmts;
+{
+ if (tlist(stmts) == lnil)
+ hsperror("do expression with no statements");
+
+ for(; tlist(ltl(stmts)) != lnil; stmts = ltl(stmts))
+ ;
+ if (ttree(lhd(stmts)) != doexp)
+ hsperror("do statements must end with expression");
+}
+
+
+/*
+ Check the precedence of a pattern or expression to ensure that
+ sections and function definitions have the correct parse.
+*/
+
+void
+checkprec(exp,qfn,right)
+ tree exp;
+ qid qfn;
+ BOOLEAN right;
+{
+ if(ttree(exp) == infixap)
+ {
+ struct infix *ftabpos = infixlookup(qfn);
+ struct infix *etabpos = infixlookup(ginffun(exp));
+
+ if (pprecedence(etabpos) > pprecedence(ftabpos) ||
+ (pprecedence(etabpos) == pprecedence(ftabpos) &&
+ ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
+ ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
+ /* SKIP */;
+ else
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section",
+ qid_to_string(qfn), qid_to_string(ginffun(exp)));
+ hsperror(errbuf);
+ }
+ }
+}
+
+
+/*
+ Checks there are no bangs in a tycon application.
+*/
+
+void
+checknobangs(app)
+ ttype app;
+{
+ if(tttype(app) == tapp)
+ {
+ if(tttype(gtarg((struct Stapp *)app)) == tbang)
+ hsperror("syntax error: unexpected ! in type");
+
+ checknobangs(gtapp((struct Stapp *)app));
+ }
+}
+
+
+/*
+ Splits a tycon application into its constructor and a list of types.
+*/
+
+void
+splittyconapp(app, tyc, tys)
+ ttype app;
+ qid *tyc;
+ list *tys;
+{
+ if(tttype(app) == tapp)
+ {
+ splittyconapp(gtapp((struct Stapp *)app), tyc, tys);
+ *tys = lapp(*tys, gtarg((struct Stapp *)app));
+ }
+ else if(tttype(app) == tname)
+ {
+ *tyc = gtypeid((struct Stname *)app);
+ *tys = Lnil;
+ }
+ else
+ {
+ hsperror("panic: splittyconap: bad tycon application (no tycon)");
+ }
+}
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_tree where
+import Ubiq -- debugging consistency check
+import UgenUtil
+
+import U_constr ( U_constr ) -- interface only
+import U_binding
+import U_coresyn ( U_coresyn ) -- interface only
+import U_hpragma ( U_hpragma ) -- interface only
+import U_list
+import U_literal
+import U_maybe
+import U_qid
+import U_ttype
+%}}
+type tree;
+ hmodule : < ghname : stringId;
+ ghimplist : list; /* [import] */
+ ghexplist : maybe; /* Maybe [entity] */
+ ghfixes : list; /* [fixop] */
+ ghmodlist : binding;
+ ghmodline : long; >;
+ fixop : < gfixop : unkId;
+ gfixinfx : long;
+ gfixprec : long; >;
+
+ ident : < gident : qid; >;
+ lit : < glit : literal; >;
+
+ ap : < gfun : tree;
+ garg : tree; >;
+ infixap : < ginffun : qid;
+ ginfarg1 : tree;
+ ginfarg2 : tree; >;
+ negate : < gnexp : tree;
+ gnxxx1 : VOID_STAR;
+ gnxxx2 : VOID_STAR; >;
+ /*
+ infixap and negate have the same size
+ so they can be rearranged in precparse
+ */
+
+ lambda : < glampats : list;
+ glamexpr : tree;
+ glamline : long; >;
+
+ let : < gletvdefs : binding;
+ gletvexpr : tree; >;
+ casee : < gcaseexpr : tree;
+ gcasebody : list;
+ gcaseline : long; >;
+ ife : < gifpred : tree;
+ gifthen : tree;
+ gifelse : tree;
+ gifline : long; >;
+ doe : < gdo : list;
+ gdoline : long; >;
+
+ dobind : < gdobindpat : tree;
+ gdobindexp : tree;
+ gdobindline : long; >;
+ doexp : < gdoexp : tree;
+ gdoexpline : long; >;
+ seqlet : < gseqlet : binding; >;
+
+ record : < grcon : qid;
+ grbinds : list; >; /* [rbind] */
+ rupdate : < gupdexp : tree;
+ gupdbinds : list; >; /* [rbind] */
+ rbind : < grbindvar : qid;
+ grbindexp : maybe; >; /* Maybe expr */
+
+ par : < gpare : tree; >;
+ as : < gasid : qid;
+ gase : tree; >;
+ lazyp : < glazyp : tree; >;
+ wildp : < >;
+
+ restr : < grestre : tree;
+ grestrt : ttype; >;
+
+ tuple : < gtuplelist : list; >;
+ llist : < gllist : list; >;
+ eenum : < gefrom : tree;
+ gestep : maybe;
+ geto : maybe; >;
+ comprh : < gcexp : tree;
+ gcquals : list; >;
+ qual : < gqpat : tree;
+ gqexp : tree; >;
+ guard : < ggexp : tree; >;
+
+ lsection: < glsexp : tree;
+ glsop : qid; >;
+ rsection: < grsop : qid;
+ grsexp : tree; >;
+
+ ccall : < gccid : stringId;
+ gccinfo : stringId;
+ gccargs : list; >;
+ scc : < gsccid : hstring;
+ gsccexp : tree; >;
+end;
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_ttype where
+import Ubiq -- debugging consistency check
+import UgenUtil
+
+import U_list
+import U_qid
+%}}
+type ttype;
+ tname : < gtypeid : qid; >;
+ namedtvar : < gnamedtvar : unkId; /* ToDo: rm unkIds entirely??? */ >;
+ tllist : < gtlist : ttype; >;
+ ttuple : < gttuple : list; >;
+ tfun : < gtin : ttype;
+ gtout : ttype; >;
+ tapp : < gtapp : ttype;
+ gtarg : ttype; >;
+ tbang : < gtbang : ttype; >;
+ context : < gtcontextl : list;
+ gtcontextt : ttype; >;
+
+ unidict : < gunidict_clas : qid;
+ gunidict_ty : ttype; >;
+ unityvartemplate: <gunityvartemplate : unkId; >;
+ uniforall : < guniforall_tv : list;
+ guniforall_ty : ttype; >;
+end;
+
--- /dev/null
+/**********************************************************************
+* *
+* *
+* Convert Types to Contexts *
+* *
+* *
+**********************************************************************/
+
+
+#include <stdio.h>
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+static void is_context_format PROTO((ttype, int)); /* forward */
+
+/*
+ partain: see also the comment by "decl" in hsparser.y.
+
+ Here, we've been given a type that must be of the form
+ "C a" or "(C1 a, C2 a, ...)" [otherwise an error]
+
+ Convert it to a list.
+*/
+
+
+list
+type2context(t)
+ ttype t;
+{
+ list args;
+
+ switch (tttype(t)) {
+ case ttuple:
+ /* returning the list is OK, but ensure items are right format */
+ args = gttuple(t);
+
+ if (tlist(args) == lnil)
+ hsperror ("type2context: () found instead of a context");
+
+ while (tlist(args) != lnil)
+ {
+ is_context_format(lhd(args), 0);
+ args = ltl(args);
+ }
+
+ return(gttuple(t)); /* args */
+
+
+ case tapp:
+ case tname:
+ /* a single item, ensure correct format */
+ is_context_format(t, 0);
+ return(lsing(t));
+
+ case namedtvar:
+ hsperror ("type2context: unexpected namedtvar found in a context");
+
+ case tllist:
+ hsperror ("type2context: list constructor found in a context");
+
+ case tfun:
+ hsperror ("type2context: arrow (->) constructor found in a context");
+
+ case context:
+ hsperror ("type2context: unexpected context-thing found in a context");
+
+ default:
+ hsperror ("type2context: totally unexpected input");
+ }
+ abort(); /* should never get here! */
+}
+
+
+/* is_context_format is the same as "type2context" except that it just performs checking */
+/* ttype is either "tycon" [class] or "tycon (named)tvar" [class var] */
+
+static void
+is_context_format(t, tyvars)
+ ttype t;
+ int tyvars;
+{
+ list rest_args;
+ ttype first_arg;
+
+ switch (tttype(t))
+ {
+ case tname :
+ /* should be just: ":: C a =>" */
+
+ if (tyvars == 0)
+ hsperror("is_context_format: variable missing after class name");
+
+ else if (tyvars > 1)
+ hsperror ("is_context_format: too many variables after class name");
+
+ /* tyvars == 1; everything is cool */
+ break;
+
+ case tapp:
+ if (tttype(gtarg(t)) != namedtvar)
+ hsperror ("is_context_format: something wrong with variable after class name");
+
+ is_context_format(gtapp(t), tyvars+1);
+ break;
+
+ case ttuple:
+ hsperror ("is_context_format: tuple found in a context");
+
+ case namedtvar:
+ hsperror ("is_context_format: unexpected namedtvar found in a context");
+
+ case tllist:
+ hsperror ("is_context_format: list constructor found in a context");
+
+ case tfun:
+ hsperror ("is_context_format: arrow (->) constructor found in a context");
+
+ case context:
+ hsperror ("is_context_format: unexpected context-thing found in a context");
+
+ default:
+ hsperror ("is_context_format: totally unexpected input");
+ }
+}
+
--- /dev/null
+/**********************************************************************
+* *
+* *
+* Declarations *
+* *
+* *
+**********************************************************************/
+
+#include "hspincl.h"
+#include "constants.h"
+#include "utils.h"
+
+#define PARSER_VERSION "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. */
+
+BOOLEAN implicitPrelude = TRUE; /* Set if we implicitly import the Prelude. */
+BOOLEAN ignorePragmas = FALSE; /* Set if we want to ignore pragmas */
+
+/* From time to time, the format of interface files may change.
+
+ So that we don't get gratuitous syntax errors or silently slurp in
+ junk info, two things: (a) the compiler injects a "this is a
+ version N interface":
+
+ {-# GHC_PRAGMA INTERFACE VERSION <n> #-}
+
+ (b) this parser has a "minimum acceptable version", below which it
+ refuses to parse the pragmas (it just considers them as comments).
+ It also has a "maximum acceptable version", above which...
+
+ The minimum is so a new parser won't try to grok overly-old
+ interfaces; the maximum (usually the current version number when
+ the parser was released) is so an old parser will not try to grok
+ since-upgraded interfaces.
+
+ If an interface has no INTERFACE VERSION line, it is taken to be
+ version 0.
+*/
+int minAcceptablePragmaVersion = 7; /* 1.3-xx ONLY */
+int maxAcceptablePragmaVersion = 7; /* 1.3-xx+ */
+int thisIfacePragmaVersion = 0;
+
+char *input_file_dir; /* The directory where the input file is. */
+
+char HiSuffix[64] = ".hi"; /* can be changed with -h flag */
+char PreludeHiSuffix[64] = ".hi"; /* can be changed with -g flag */
+
+static BOOLEAN verbose = FALSE; /* Set for verbose messages. */
+
+/* Forward decls */
+static void who_am_i PROTO((void));
+
+/**********************************************************************
+* *
+* *
+* Utility Functions *
+* *
+* *
+**********************************************************************/
+
+# include <stdio.h>
+# include "constants.h"
+# include "hspincl.h"
+# include "utils.h"
+
+void
+process_args(argc,argv)
+ int argc;
+ char **argv;
+{
+ BOOLEAN keep_munging_option = FALSE;
+
+ imports_dirlist = mklnil();
+ sys_imports_dirlist = mklnil();
+
+ argc--, argv++;
+
+ while (argc > 0 && argv[0][0] == '-') {
+
+ keep_munging_option = TRUE;
+
+ while (keep_munging_option && *++*argv != '\0') {
+ switch(**argv) {
+
+ /* -I dir */
+ case 'I':
+ imports_dirlist = lapp(imports_dirlist,*argv+1);
+ keep_munging_option = FALSE;
+ break;
+
+ /* -J dir (for system imports) */
+ case 'J':
+ sys_imports_dirlist = lapp(sys_imports_dirlist,*argv+1);
+ keep_munging_option = FALSE;
+ break;
+
+ case 'g':
+ strcpy(PreludeHiSuffix, *argv+1);
+ keep_munging_option = FALSE;
+ break;
+
+ case 'h':
+ strcpy(HiSuffix, *argv+1);
+ keep_munging_option = FALSE;
+ break;
+
+ case 'v':
+ who_am_i(); /* identify myself */
+ verbose = TRUE;
+ break;
+
+ case 'N':
+ nonstandardFlag = TRUE;
+ acceptPrim = TRUE;
+ break;
+
+ case '2':
+ haskell1_2Flag = TRUE;
+ break;
+
+ case 'S':
+ ignoreSCC = FALSE;
+ break;
+
+ case 'p':
+ ignorePragmas = TRUE;
+ break;
+
+ case 'P':
+ implicitPrelude = FALSE;
+ break;
+
+ case 'D':
+#ifdef HSP_DEBUG
+ { extern int yydebug;
+ yydebug = 1;
+ }
+#endif
+ break;
+
+ /* -Hn -- Use Hash Table, Size n (if given) */
+ case 'H':
+ hashIds = TRUE;
+ if(*(*argv+1)!= '\0')
+ hash_table_size = atoi(*argv+1);
+ break;
+ case 'E':
+ etags = TRUE;
+ break;
+ }
+ }
+ argc--, argv++;
+ }
+
+ if(argc >= 1 && freopen(argv[0], "r", stdin) == NULL) {
+ fprintf(stderr, "Cannot open %s.\n", argv[0]);
+ exit(1);
+ }
+
+ if(argc >= 2 && freopen(argv[1], "w", stdout) == NULL) {
+ fprintf(stderr, "Cannot open %s.\n", argv[1]);
+ exit(1);
+ }
+
+
+ /* By default, imports come from the directory of the source file */
+ if ( argc >= 1 )
+ {
+ char *endchar;
+
+ input_file_dir = xmalloc (strlen(argv[0]) + 1);
+ strcpy(input_file_dir, argv[0]);
+#ifdef macintosh
+ endchar = rindex(input_file_dir, (int) ':');
+#else
+ endchar = rindex(input_file_dir, (int) '/');
+#endif /* ! macintosh */
+
+ if ( endchar == NULL )
+ {
+ free(input_file_dir);
+ input_file_dir = ".";
+ }
+ else
+ *endchar = '\0';
+ }
+
+ /* No input file -- imports come from the current directory first */
+ else
+ input_file_dir = ".";
+
+ imports_dirlist = mklcons( input_file_dir, imports_dirlist );
+
+ 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
+error(s)
+ char *s;
+{
+ fprintf(stderr, "PARSER: Error %s\n", s);
+ exit(1);
+}
+
+static void
+who_am_i(void)
+{
+ fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION);
+}
+
+list
+lconc(l1, l2)
+ list l1;
+ list l2;
+{
+ list t;
+
+ if (tlist(l1) == lnil)
+ return(l2);
+ for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
+ ;
+ ltl(t) = l2;
+ return(l1);
+}
+
+list
+lapp(list l1, VOID_STAR l2)
+{
+ list t;
+
+ if (tlist(l1) == lnil)
+ return(mklcons(l2, mklnil()));
+ for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
+ ;
+ ltl(t) = mklcons(l2, mklnil());
+ return(l1);
+}
--- /dev/null
+/*
+ Utility Definitions.
+*/
+
+#ifndef __UTILS_H
+#define __UTILS_H
+
+/* stuff from util.c */
+extern tree root;
+extern list Lnil;
+extern list all;
+
+extern BOOLEAN nonstandardFlag;
+extern BOOLEAN hashIds;
+extern BOOLEAN acceptPrim;
+extern BOOLEAN etags;
+
+extern BOOLEAN ignoreSCC;
+
+extern BOOLEAN implicitPrelude;
+extern BOOLEAN ignorePragmas;
+
+extern int minAcceptablePragmaVersion;
+extern int maxAcceptablePragmaVersion;
+extern int thisIfacePragmaVersion;
+
+extern unsigned hash_table_size;
+extern char *input_file_dir;
+
+extern list imports_dirlist;
+extern list sys_imports_dirlist;
+
+extern char HiSuffix[];
+extern char PreludeHiSuffix[];
+
+void process_args PROTO((int, char **));
+
+/* end of util.c stuff */
+
+list mklcons PROTO((void *h, list t)); /* if we have PROTO, we have "void *" */
+list lapp PROTO((list l1, void *l2));
+list lconc PROTO((list l1, list l2));
+
+#define lsing(l) mklcons(l, Lnil) /* Singleton Lists */
+#define ldub(l1, l2) mklcons(l1, lsing(l2)) /* Two-element Lists */
+
+#define FN fns[icontexts]
+#define SAMEFN samefn[icontexts]
+#define PREVPATT prevpatt[icontexts]
+
+id installid PROTO((char *)); /* Create a new identifier */
+hstring installHstring PROTO((int, char *)); /* Create a new literal string */
+
+id install_literal PROTO((char *));
+char *id_to_string PROTO((id));
+
+id qid_to_id PROTO((qid));
+char *qid_to_string PROTO((qid));
+char *qid_to_mod PROTO((qid)); /* NULL if unqual */
+char *qid_to_pmod PROTO((qid)); /* "?" if unqual */
+qid creategid PROTO((long));
+
+/* partain additions */
+
+char *xmalloc PROTO((unsigned)); /* just a GNU-style error-checking malloc */
+int printf PROTO((const char *, ...));
+int fprintf PROTO((FILE *, const char *, ...));
+/*varies (sun/alpha): int fputc PROTO((char, FILE *)); */
+int fputs PROTO((const char *, FILE *));
+int sscanf PROTO((const char *, const char *, ...));
+long strtol PROTO((const char *, char **, int));
+size_t fread PROTO((void *, size_t, size_t, FILE *));
+int fclose PROTO((FILE *));
+int isatty PROTO((int));
+/*extern ??? _filbuf */
+/*extern ??? _flsbuf */
+
+void pprogram PROTO((tree));
+
+void format_string PROTO((FILE *, unsigned char *, int));
+list type2context PROTO((ttype));
+pbinding createpat PROTO((pbinding, binding));
+void process_args PROTO((int, char **));
+void hash_init PROTO((void));
+void print_hash_table PROTO((void));
+long int hash_index PROTO((id));
+void yyinit PROTO((void));
+int yyparse PROTO((void));
+int yylex PROTO((void));
+void setyyin PROTO((char *));
+void yyerror PROTO((char *));
+void error PROTO((char *));
+void hsperror PROTO((char *));
+
+void makeinfix PROTO((id, int, int, id, long, long, id, id, long, long, long, list));
+struct infix *infixlookup PROTO((qid));
+int pprecedence PROTO((struct infix *));
+int pfixity PROTO((struct infix *));
+char * infixstr PROTO((int));
+long infixint PROTO((int));
+
+void hsincindent PROTO((void));
+void hssetindent PROTO((void));
+void hsendindent PROTO((void));
+void hsindentoff PROTO((void));
+
+int checkfixity PROTO((char *));
+void checksamefn PROTO((qid));
+void checkinpat PROTO((void));
+
+void expORpat PROTO((int,tree));
+/* the "int" arg says what we want; it is one of: */
+#define LEGIT_PATT 1
+#define LEGIT_EXPR 2
+
+BOOLEAN lhs_is_patt PROTO((tree));
+tree function PROTO((tree));
+void extendfn PROTO((binding, binding));
+void checkorder PROTO((binding));
+
+void precparse PROTO((tree));
+void checkprec PROTO((tree, qid, BOOLEAN));
+void checkdostmts PROTO((list));
+void checknobangs PROTO((ttype));
+void splittyconapp PROTO((ttype, qid *, list *));
+
+BOOLEAN isconstr PROTO((char *));
+void setstartlineno PROTO((void));
+void find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
+
+/* mattson additions */
+char *xstrdup PROTO((char *)); /* Duplicate a string */
+char *xstrndup PROTO((char *, unsigned)); /* Duplicate a substring */
+char *xrealloc PROTO((char *, unsigned)); /* Re-allocate a string */
+
+#endif /* __UTILS_H */
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AbsPrel where
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreExpr)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(NamedThing, Outputable)
-import PlainCore(PlainCoreExpr(..))
-import PrelFuns(gLASGOW_MISC, gLASGOW_ST, pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_IO, pRELUDE_LIST, pRELUDE_PRIMIO, pRELUDE_PS, pRELUDE_RATIO, pRELUDE_TEXT)
-import PrelVals(aBSENT_ERROR_ID, appendId, augmentId, buildId, eRROR_ID, foldlId, foldrId, integerMinusOneId, integerPlusOneId, integerPlusTwoId, integerZeroId, mkBuild, mkFoldl, mkFoldr, pAT_ERROR_ID, packStringForCId, realWorldPrimId, unpackCString2Id, unpackCStringAppendId, unpackCStringFoldrId, unpackCStringId, voidPrimId)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(HeapRequirement(..), PrimOp(..), PrimOpResultInfo(..), fragilePrimOp, getPrimOpResultInfo, isCompareOp, pprPrimOp, primOpCanTriggerGC, primOpHeapReq, primOpIsCheap, primOpNameInfo, primOpNeedsWrapper, primOpOkForSpeculation, showPrimOp, typeOfPrimOp)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import TysPrim(addrPrimTy, addrPrimTyCon, charPrimTy, charPrimTyCon, doublePrimTy, doublePrimTyCon, floatPrimTy, floatPrimTyCon, intPrimTy, intPrimTyCon, realWorldStatePrimTy, realWorldTy, realWorldTyCon, voidPrimTy, wordPrimTy, wordPrimTyCon)
-import TysWiredIn(addrDataCon, addrTy, addrTyCon, boolTy, boolTyCon, charDataCon, charTy, charTyCon, cmpTagTy, consDataCon, doubleDataCon, doubleTy, doubleTyCon, eqPrimDataCon, falseDataCon, floatDataCon, floatTy, floatTyCon, getStatePairingConInfo, gtPrimDataCon, intDataCon, intTy, intTyCon, integerDataCon, integerTy, integerTyCon, liftDataCon, liftTyCon, listTyCon, ltPrimDataCon, mkLiftTy, mkListTy, mkPrimIoTy, mkTupleTy, nilDataCon, ratioDataCon, rationalTy, rationalTyCon, realWorldStateTy, stateDataCon, stringTy, trueDataCon, unitTy, wordDataCon, wordTy, wordTyCon)
-import UniType(TauType(..), UniType)
-import Unique(Unique)
-data GlobalSwitch
-data CoreExpr a b
-data HeapOffset
-data Id
-data Labda a
-data Name
-type PlainCoreExpr = CoreExpr Id Id
-data PprStyle
-data PrimKind
-data HeapRequirement = NoHeapRequired | FixedHeapRequired HeapOffset | VariableHeapRequired
-data PrimOp
- = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp
-data PrimOpResultInfo = ReturnsPrim PrimKind | ReturnsAlg TyCon
-data TyCon
-type TauType = UniType
-data UniType
-data Unique
-gLASGOW_MISC :: _PackedString
-gLASGOW_ST :: _PackedString
-pRELUDE :: _PackedString
-pRELUDE_BUILTIN :: _PackedString
-pRELUDE_CORE :: _PackedString
-pRELUDE_IO :: _PackedString
-pRELUDE_LIST :: _PackedString
-pRELUDE_PRIMIO :: _PackedString
-pRELUDE_PS :: _PackedString
-pRELUDE_RATIO :: _PackedString
-pRELUDE_TEXT :: _PackedString
-aBSENT_ERROR_ID :: Id
-appendId :: Id
-augmentId :: Id
-buildId :: Id
-eRROR_ID :: Id
-foldlId :: Id
-foldrId :: Id
-integerMinusOneId :: Id
-integerPlusOneId :: Id
-integerPlusTwoId :: Id
-integerZeroId :: Id
-mkBuild :: UniType -> TyVar -> Id -> Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkFoldl :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
-mkFoldr :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
-fragilePrimOp :: PrimOp -> Bool
-getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
-isCompareOp :: PrimOp -> Bool
-addrPrimTy :: UniType
-addrPrimTyCon :: TyCon
-charPrimTy :: UniType
-charPrimTyCon :: TyCon
-doublePrimTy :: UniType
-doublePrimTyCon :: TyCon
-floatPrimTy :: UniType
-floatPrimTyCon :: TyCon
-intPrimTy :: UniType
-intPrimTyCon :: TyCon
-addrDataCon :: Id
-addrTy :: UniType
-addrTyCon :: TyCon
-boolTy :: UniType
-boolTyCon :: TyCon
-builtinNameInfo :: (GlobalSwitch -> Bool) -> (_PackedString -> Labda Name, _PackedString -> Labda Name)
-charDataCon :: Id
-charTy :: UniType
-charTyCon :: TyCon
-cmpTagTy :: UniType
-consDataCon :: Id
-doubleDataCon :: Id
-doubleTy :: UniType
-doubleTyCon :: TyCon
-eqPrimDataCon :: Id
-falseDataCon :: Id
-floatDataCon :: Id
-floatTy :: UniType
-floatTyCon :: TyCon
-getStatePairingConInfo :: UniType -> (Id, UniType)
-gtPrimDataCon :: Id
-intDataCon :: Id
-intTy :: UniType
-intTyCon :: TyCon
-integerDataCon :: Id
-integerTy :: UniType
-integerTyCon :: TyCon
-liftDataCon :: Id
-liftTyCon :: TyCon
-listTyCon :: TyCon
-ltPrimDataCon :: Id
-mkFunTy :: UniType -> UniType -> UniType
-pAT_ERROR_ID :: Id
-packStringForCId :: Id
-realWorldPrimId :: Id
-unpackCString2Id :: Id
-unpackCStringAppendId :: Id
-unpackCStringFoldrId :: Id
-unpackCStringId :: Id
-voidPrimId :: Id
-pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep
-primOpCanTriggerGC :: PrimOp -> Bool
-primOpHeapReq :: PrimOp -> HeapRequirement
-primOpIsCheap :: PrimOp -> Bool
-primOpNameInfo :: PrimOp -> (_PackedString, Name)
-primOpNeedsWrapper :: PrimOp -> Bool
-primOpOkForSpeculation :: PrimOp -> Bool
-showPrimOp :: PprStyle -> PrimOp -> [Char]
-typeOfPrimOp :: PrimOp -> UniType
-realWorldStatePrimTy :: UniType
-realWorldTy :: UniType
-realWorldTyCon :: TyCon
-voidPrimTy :: UniType
-wordPrimTy :: UniType
-wordPrimTyCon :: TyCon
-mkLiftTy :: UniType -> UniType
-mkListTy :: UniType -> UniType
-mkPrimIoTy :: UniType -> UniType
-mkTupleTy :: Int -> [UniType] -> UniType
-nilDataCon :: Id
-ratioDataCon :: Id
-rationalTy :: UniType
-rationalTyCon :: TyCon
-readUnfoldingPrimOp :: _PackedString -> PrimOp
-realWorldStateTy :: UniType
-stateDataCon :: Id
-stringTy :: UniType
-trueDataCon :: Id
-unitTy :: UniType
-wordDataCon :: Id
-wordTy :: UniType
-wordTyCon :: TyCon
-instance Eq GlobalSwitch
-instance Eq Id
-instance Eq PrimKind
-instance Eq PrimOp
-instance Eq TyCon
-instance Eq Unique
-instance Ord GlobalSwitch
-instance Ord Id
-instance Ord PrimKind
-instance Ord TyCon
-instance Ord Unique
-instance NamedThing Id
-instance NamedThing TyCon
-instance Outputable Id
-instance Outputable PrimKind
-instance Outputable PrimOp
-instance Outputable TyCon
-instance Text Unique
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[AbsPrel]{The @AbsPrel@ interface to the compiler's prelude knowledge}
-
-\begin{code}
-#include "HsVersions.h"
-
-module AbsPrel (
-
--- unlike most export lists, this one is actually interesting :-)
-
- -- re-export some PrimOp stuff:
- PrimOp(..), typeOfPrimOp, primOpNameInfo,
- HeapRequirement(..), primOpHeapReq, primOpCanTriggerGC,
- primOpNeedsWrapper, primOpOkForSpeculation, primOpIsCheap,
- fragilePrimOp,
- PrimOpResultInfo(..), getPrimOpResultInfo,
- pprPrimOp, showPrimOp, isCompareOp,
- readUnfoldingPrimOp, -- actually, defined herein
-
- pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
- pRELUDE_LIST, pRELUDE_TEXT, --OLD: pRELUDE_ARRAY, pRELUDE_COMPLEX,
- pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
- gLASGOW_ST, {-gLASGOW_IO,-} gLASGOW_MISC,
-
- -- lookup functions for built-in names, for the renamer:
- builtinNameInfo,
-
- -- *odd* values that need to be reached out and grabbed:
- eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
- packStringForCId,
- unpackCStringId, unpackCString2Id,
- unpackCStringAppendId, unpackCStringFoldrId,
- integerZeroId, integerPlusOneId,
- integerPlusTwoId, integerMinusOneId,
-
-#ifdef DPH
- -- ProcessorClass
- toPodId,
-
- -- Pid Class
- fromDomainId, toDomainId,
-#endif {- Data Parallel Haskell -}
-
- -----------------------------------------------------
- -- the rest of the export list is organised by *type*
- -----------------------------------------------------
-
- -- "type": functions ("arrow" type constructor)
- mkFunTy,
-
- -- type: Bool
- boolTyCon, boolTy, falseDataCon, trueDataCon,
-
- -- types: Char#, Char, String (= [Char])
- charPrimTy, charTy, stringTy,
- charPrimTyCon, charTyCon, charDataCon,
-
- -- type: CMP_TAG (used in deriving)
- cmpTagTy, ltPrimDataCon, eqPrimDataCon, gtPrimDataCon,
-
- -- types: Double#, Double
- doublePrimTy, doubleTy,
- doublePrimTyCon, doubleTyCon, doubleDataCon,
-
- -- types: Float#, Float
- floatPrimTy, floatTy,
- floatPrimTyCon, floatTyCon, floatDataCon,
-
- -- types: Glasgow *primitive* arrays, sequencing and I/O
- mkPrimIoTy, -- to typecheck "mainIO", "mainPrimIO" & for _ccall_s
- realWorldStatePrimTy, realWorldStateTy{-boxed-},
- realWorldTy, realWorldTyCon, realWorldPrimId,
- stateDataCon, getStatePairingConInfo,
-
- -- types: Void# (only used within the compiler)
- voidPrimTy, voidPrimId,
-
- -- types: Addr#, Int#, Word#, Int
- intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon,
- wordPrimTyCon, wordPrimTy, wordTy, wordTyCon, wordDataCon,
- addrPrimTyCon, addrPrimTy, addrTy, addrTyCon, addrDataCon,
-
- -- types: Integer, Rational (= Ratio Integer)
- integerTy, rationalTy,
- integerTyCon, integerDataCon,
- rationalTyCon, ratioDataCon,
-
- -- type: Lift
- liftTyCon, liftDataCon, mkLiftTy,
-
- -- type: List
- listTyCon, mkListTy, nilDataCon, consDataCon,
- -- NOT USED: buildDataCon,
-
- -- type: tuples
- mkTupleTy, unitTy,
-
- -- packed Strings
--- packedStringTyCon, packedStringTy, psDataCon, cpsDataCon,
-
- -- for compilation of List Comprehensions and foldr
- foldlId, foldrId, mkFoldl, mkFoldr,
- mkBuild, buildId, augmentId, appendId,
-
-#ifdef DPH
- mkProcessorTy,
- mkPodTy, mkPodNTy, podTyCon, -- user model
- mkPodizedPodNTy, -- podized model
- mkInterfacePodNTy, interfacePodTyCon, mKINTERPOD_ID, -- interface model
-
- -- Misc used during podization
- primIfromPodNSelectorId,
-#endif {- Data Parallel Haskell -}
-
- -- and, finally, we must put in some (abstract) data types,
- -- to make the interface self-sufficient
- GlobalSwitch, Id, Maybe, Name, PprStyle, PrimKind, HeapOffset,
- TyCon, UniType, TauType(..), Unique, CoreExpr, PlainCoreExpr(..)
-
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA mkStatePrimTy)
-
-#ifndef __GLASGOW_HASKELL__
- ,TAG_
-#endif
- ) where
-
-#ifdef DPH
-import TyPod
-import TyProcs
-#endif {- Data Parallel Haskell -}
-
-import PrelFuns -- help functions, types and things
-import PrimKind
-
-import TysPrim -- TYPES
-import TysWiredIn
-import PrelVals -- VALUES
-import PrimOps -- PRIMITIVE OPS
-
-import AbsUniType ( getTyConDataCons, TyCon
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
- )
-import CmdLineOpts ( GlobalSwitch(..) )
-import FiniteMap
-import Id ( Id )
---OLD:import NameEnv
-import Maybes
-import Unique -- *Key stuff
-import Util
-\end{code}
-
-This little devil is too small to merit its own ``TyFun'' module:
-
-\begin{code}
-mkFunTy = UniFun
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[builtinNameInfo]{Lookup built-in names}
-%* *
-%************************************************************************
-
-We have two ``builtin name funs,'' one to look up @TyCons@ and
-@Classes@, the other to look up values.
-
-\begin{code}
-builtinNameInfo :: (GlobalSwitch -> Bool) -- access to global cmd-line flags
- -> (FAST_STRING -> Maybe Name, -- name lookup fn for values
- FAST_STRING -> Maybe Name) -- name lookup fn for tycons/classes
-
-builtinNameInfo switch_is_on
- = (init_val_lookup_fn, init_tc_lookup_fn)
- where
- --
- -- values (including data constructors)
- --
- init_val_lookup_fn
- = if switch_is_on HideBuiltinNames then
- (\ x -> Nothing)
- else if switch_is_on HideMostBuiltinNames then
- lookupFM (listToFM min_val_assoc_list)
- -- OLD: mkStringLookupFn min_val_assoc_list False{-not pre-sorted-}
- else
- lookupFM (listToFM (concat list_of_val_assoc_lists))
- -- mkStringLookupFn (concat list_of_val_assoc_lists) False{-not pre-sorted-}
-
- min_val_assoc_list -- this is an ad-hoc list; what "happens"
- = totally_wired_in_Ids -- to be needed (when compiling bits of
- ++ unboxed_ops -- Prelude).
- ++ (concat (map pcDataConNameInfo min_nonprim_tycon_list))
-
- -- We let a lot of "non-standard" values be visible, so that we
- -- can make sense of them in interface pragmas. It's cool, though
- -- -- they all have "non-standard" names, so they won't get past
- -- the parser in user code.
- list_of_val_assoc_lists
- = [ -- each list is empty or all there
-
- totally_wired_in_Ids,
-
- concat (map pcDataConNameInfo data_tycons),
-
- unboxed_ops,
-
- if switch_is_on ForConcurrent then parallel_vals else []
- ]
-
- --
- -- type constructors and classes
- --
- init_tc_lookup_fn
- = if switch_is_on HideBuiltinNames then
- (\ x -> Nothing)
- else if switch_is_on HideMostBuiltinNames then
- lookupFM (listToFM min_tc_assoc_list)
- --OLD: mkStringLookupFn min_tc_assoc_list False{-not pre-sorted-}
- else
- lookupFM (listToFM (
- -- OLD: mkStringLookupFn
- map pcTyConNameInfo (data_tycons ++ synonym_tycons)
- ++ std_tycon_list -- TyCons not quite so wired in
- ++ std_class_list
- ++ prim_tys))
- -- The prim_tys,etc., are OK, because they all
- -- have "non-standard" names (and we really
- -- want them for interface pragmas).
- --OLD: False{-not pre-sorted-}
-
- min_tc_assoc_list -- again, pretty ad-hoc
- = prim_tys ++ (map pcTyConNameInfo min_nonprim_tycon_list)
---HA! ++ std_class_list -- no harm in this
-
-min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
- = [ boolTyCon,
- cmpTagTyCon,
- charTyCon,
- intTyCon,
- floatTyCon,
- doubleTyCon,
- integerTyCon,
- ratioTyCon,
- liftTyCon,
- return2GMPsTyCon, -- ADR asked for these last two (WDP 94/11)
- returnIntAndGMPTyCon ]
-
--- sigh: I (WDP) think these should be local defns
--- but you cannot imagine how bad it is for speed (w/ GHC)
-prim_tys = map pcTyConNameInfo prim_tycons
-
--- values
-
-totally_wired_in_Ids
- = [(SLIT(":"), WiredInVal consDataCon),
- (SLIT("error"), WiredInVal eRROR_ID),
- (SLIT("patError#"), WiredInVal pAT_ERROR_ID), -- occurs in i/faces
- (SLIT("parError#"), WiredInVal pAR_ERROR_ID), -- ditto
- (SLIT("_trace"), WiredInVal tRACE_ID),
-
- -- now the foldr/build Ids, which need to be built in
- -- because they have magic unfoldings
- (SLIT("_build"), WiredInVal buildId),
- (SLIT("_augment"), WiredInVal augmentId),
- (SLIT("foldl"), WiredInVal foldlId),
- (SLIT("foldr"), WiredInVal foldrId),
- (SLIT("unpackAppendPS#"), WiredInVal unpackCStringAppendId),
- (SLIT("unpackFoldrPS#"), WiredInVal unpackCStringFoldrId),
-
- (SLIT("_runST"), WiredInVal runSTId),
- (SLIT("_seq_"), WiredInVal seqId), -- yes, used in sequential-land, too
- -- WDP 95/11
- (SLIT("realWorld#"), WiredInVal realWorldPrimId)
- ]
-
-parallel_vals
- =[(SLIT("_par_"), WiredInVal parId),
- (SLIT("_fork_"), WiredInVal forkId)
-#ifdef GRAN
- ,
- (SLIT("_parLocal_"), WiredInVal parLocalId),
- (SLIT("_parGlobal_"), WiredInVal parGlobalId)
- -- Add later:
- -- (SLIT("_parAt_"), WiredInVal parAtId)
- -- (SLIT("_parAtForNow_"), WiredInVal parAtForNowId)
- -- (SLIT("_copyable_"), WiredInVal copyableId)
- -- (SLIT("_noFollow_"), WiredInVal noFollowId)
-#endif {-GRAN-}
- ]
-
-unboxed_ops
- = (map primOpNameInfo lots_of_primops)
- ++
- -- plus some of the same ones but w/ different names
- [case (primOpNameInfo IntAddOp) of (_,n) -> (SLIT("+#"), n),
- case (primOpNameInfo IntSubOp) of (_,n) -> (SLIT("-#"), n),
- case (primOpNameInfo IntMulOp) of (_,n) -> (SLIT("*#"), n),
- case (primOpNameInfo IntGtOp) of (_,n) -> (SLIT(">#"), n),
- case (primOpNameInfo IntGeOp) of (_,n) -> (SLIT(">=#"), n),
- case (primOpNameInfo IntEqOp) of (_,n) -> (SLIT("==#"), n),
- case (primOpNameInfo IntNeOp) of (_,n) -> (SLIT("/=#"), n),
- case (primOpNameInfo IntLtOp) of (_,n) -> (SLIT("<#"), n),
- case (primOpNameInfo IntLeOp) of (_,n) -> (SLIT("<=#"), n),
- case (primOpNameInfo DoubleAddOp) of (_,n) -> (SLIT("+##"), n),
- case (primOpNameInfo DoubleSubOp) of (_,n) -> (SLIT("-##"), n),
- case (primOpNameInfo DoubleMulOp) of (_,n) -> (SLIT("*##"), n),
- case (primOpNameInfo DoubleDivOp) of (_,n) -> (SLIT("/##"), n),
- case (primOpNameInfo DoublePowerOp) of (_,n) -> (SLIT("**##"), n),
- case (primOpNameInfo DoubleGtOp) of (_,n) -> (SLIT(">##"), n),
- case (primOpNameInfo DoubleGeOp) of (_,n) -> (SLIT(">=##"), n),
- case (primOpNameInfo DoubleEqOp) of (_,n) -> (SLIT("==##"), n),
- case (primOpNameInfo DoubleNeOp) of (_,n) -> (SLIT("/=##"), n),
- case (primOpNameInfo DoubleLtOp) of (_,n) -> (SLIT("<##"), n),
- case (primOpNameInfo DoubleLeOp) of (_,n) -> (SLIT("<=##"), n)]
-
-prim_tycons
- = [addrPrimTyCon,
- arrayPrimTyCon,
- byteArrayPrimTyCon,
- charPrimTyCon,
- doublePrimTyCon,
- floatPrimTyCon,
- intPrimTyCon,
- mallocPtrPrimTyCon,
- mutableArrayPrimTyCon,
- mutableByteArrayPrimTyCon,
- synchVarPrimTyCon,
- realWorldTyCon,
- stablePtrPrimTyCon,
- statePrimTyCon,
- wordPrimTyCon
- ]
-
-std_tycon_list
- = let
- swizzle_over (mod, nm, key, arity, is_data)
- = let
- fname = mkPreludeCoreName mod nm
- in
- (nm, PreludeTyCon key fname arity is_data)
- in
- map swizzle_over
- [--(pRELUDE_IO, SLIT("Request"), requestTyConKey, 0, True),
---OLD: (pRELUDE_IO, SLIT("Response"), responseTyConKey, 0, True),
- (pRELUDE_IO, SLIT("Dialogue"), dialogueTyConKey, 0, False),
- (SLIT("PreludeMonadicIO"), SLIT("IO"), iOTyConKey, 1, False)
- ]
-
--- Several of these are non-std, but they have non-std
--- names, so they won't get past the parser in user code
--- (but will be visible for interface-pragma purposes).
-
-data_tycons
- = [addrTyCon,
- boolTyCon,
--- byteArrayTyCon,
- charTyCon,
- cmpTagTyCon,
- doubleTyCon,
- floatTyCon,
- intTyCon,
- integerTyCon,
- liftTyCon,
- mallocPtrTyCon,
--- mutableArrayTyCon,
--- mutableByteArrayTyCon,
- ratioTyCon,
- return2GMPsTyCon,
- returnIntAndGMPTyCon,
- stablePtrTyCon,
- stateAndAddrPrimTyCon,
- stateAndArrayPrimTyCon,
- stateAndByteArrayPrimTyCon,
- stateAndCharPrimTyCon,
- stateAndDoublePrimTyCon,
- stateAndFloatPrimTyCon,
- stateAndIntPrimTyCon,
- stateAndMallocPtrPrimTyCon,
- stateAndMutableArrayPrimTyCon,
- stateAndMutableByteArrayPrimTyCon,
- stateAndSynchVarPrimTyCon,
- stateAndPtrPrimTyCon,
- stateAndStablePtrPrimTyCon,
- stateAndWordPrimTyCon,
- stateTyCon,
- wordTyCon
-#ifdef DPH
- ,podTyCon
-#endif {- Data Parallel Haskell -}
- ]
-
-synonym_tycons
- = [primIoTyCon,
- rationalTyCon,
- stTyCon,
- stringTyCon]
-
-std_class_list
- = let
- swizzle_over (str, key)
- = (str, PreludeClass key (mkPreludeCoreName pRELUDE_CORE str))
- in
- map swizzle_over
- [(SLIT("Eq"), eqClassKey),
- (SLIT("Ord"), ordClassKey),
- (SLIT("Num"), numClassKey),
- (SLIT("Real"), realClassKey),
- (SLIT("Integral"), integralClassKey),
- (SLIT("Fractional"), fractionalClassKey),
- (SLIT("Floating"), floatingClassKey),
- (SLIT("RealFrac"), realFracClassKey),
- (SLIT("RealFloat"), realFloatClassKey),
- (SLIT("Ix"), ixClassKey),
- (SLIT("Enum"), enumClassKey),
- (SLIT("Text"), textClassKey),
- (SLIT("_CCallable"), cCallableClassKey),
- (SLIT("_CReturnable"), cReturnableClassKey),
- (SLIT("Binary"), binaryClassKey)
-#ifdef DPH
- , (SLIT("Pid"), pidClassKey)
- , (SLIT("Processor"),processorClassKey)
-#endif {- Data Parallel Haskell -}
- ]
-
-lots_of_primops
- = [ CharGtOp,
- CharGeOp,
- CharEqOp,
- CharNeOp,
- CharLtOp,
- CharLeOp,
- IntGtOp,
- IntGeOp,
- IntEqOp,
- IntNeOp,
- IntLtOp,
- IntLeOp,
- WordGtOp,
- WordGeOp,
- WordEqOp,
- WordNeOp,
- WordLtOp,
- WordLeOp,
- AddrGtOp,
- AddrGeOp,
- AddrEqOp,
- AddrNeOp,
- AddrLtOp,
- AddrLeOp,
- FloatGtOp,
- FloatGeOp,
- FloatEqOp,
- FloatNeOp,
- FloatLtOp,
- FloatLeOp,
- DoubleGtOp,
- DoubleGeOp,
- DoubleEqOp,
- DoubleNeOp,
- DoubleLtOp,
- DoubleLeOp,
- OrdOp,
- ChrOp,
- IntAddOp,
- IntSubOp,
- IntMulOp,
- IntQuotOp,
- IntRemOp,
- IntNegOp,
- AndOp,
- OrOp,
- NotOp,
- SllOp,
- SraOp,
- SrlOp,
- ISllOp,
- ISraOp,
- ISrlOp,
- Int2WordOp,
- Word2IntOp,
- Int2AddrOp,
- Addr2IntOp,
- FloatAddOp,
- FloatSubOp,
- FloatMulOp,
- FloatDivOp,
- FloatNegOp,
- Float2IntOp,
- Int2FloatOp,
- FloatExpOp,
- FloatLogOp,
- FloatSqrtOp,
- FloatSinOp,
- FloatCosOp,
- FloatTanOp,
- FloatAsinOp,
- FloatAcosOp,
- FloatAtanOp,
- FloatSinhOp,
- FloatCoshOp,
- FloatTanhOp,
- FloatPowerOp,
- DoubleAddOp,
- DoubleSubOp,
- DoubleMulOp,
- DoubleDivOp,
- DoubleNegOp,
- Double2IntOp,
- Int2DoubleOp,
- Double2FloatOp,
- Float2DoubleOp,
- DoubleExpOp,
- DoubleLogOp,
- DoubleSqrtOp,
- DoubleSinOp,
- DoubleCosOp,
- DoubleTanOp,
- DoubleAsinOp,
- DoubleAcosOp,
- DoubleAtanOp,
- DoubleSinhOp,
- DoubleCoshOp,
- DoubleTanhOp,
- DoublePowerOp,
- IntegerAddOp,
- IntegerSubOp,
- IntegerMulOp,
- IntegerQuotRemOp,
- IntegerDivModOp,
- IntegerNegOp,
- IntegerCmpOp,
- Integer2IntOp,
- Int2IntegerOp,
- Word2IntegerOp,
- Addr2IntegerOp,
- FloatEncodeOp,
- FloatDecodeOp,
- DoubleEncodeOp,
- DoubleDecodeOp,
- NewArrayOp,
- NewByteArrayOp CharKind,
- NewByteArrayOp IntKind,
- NewByteArrayOp AddrKind,
- NewByteArrayOp FloatKind,
- NewByteArrayOp DoubleKind,
- SameMutableArrayOp,
- SameMutableByteArrayOp,
- ReadArrayOp,
- WriteArrayOp,
- IndexArrayOp,
- ReadByteArrayOp CharKind,
- ReadByteArrayOp IntKind,
- ReadByteArrayOp AddrKind,
- ReadByteArrayOp FloatKind,
- ReadByteArrayOp DoubleKind,
- WriteByteArrayOp CharKind,
- WriteByteArrayOp IntKind,
- WriteByteArrayOp AddrKind,
- WriteByteArrayOp FloatKind,
- WriteByteArrayOp DoubleKind,
- IndexByteArrayOp CharKind,
- IndexByteArrayOp IntKind,
- IndexByteArrayOp AddrKind,
- IndexByteArrayOp FloatKind,
- IndexByteArrayOp DoubleKind,
- IndexOffAddrOp CharKind,
- IndexOffAddrOp IntKind,
- IndexOffAddrOp AddrKind,
- IndexOffAddrOp FloatKind,
- IndexOffAddrOp DoubleKind,
- UnsafeFreezeArrayOp,
- UnsafeFreezeByteArrayOp,
- NewSynchVarOp,
- ReadArrayOp,
- TakeMVarOp,
- PutMVarOp,
- ReadIVarOp,
- WriteIVarOp,
- MakeStablePtrOp,
- DeRefStablePtrOp,
- ReallyUnsafePtrEqualityOp,
- ErrorIOPrimOp,
-#ifdef GRAN
- ParGlobalOp,
- ParLocalOp,
-#endif {-GRAN-}
- SeqOp,
- ParOp,
- ForkOp,
- DelayOp,
- WaitOp
- ]
-\end{code}
-
-\begin{code}
-readUnfoldingPrimOp :: FAST_STRING -> PrimOp
-
-readUnfoldingPrimOp
- = let
- -- "reverse" lookup table
- tbl = map (\ o -> let { (str,_) = primOpNameInfo o } in (str, o)) lots_of_primops
- in
- \ str -> case [ op | (s, op) <- tbl, s == str ] of
- (op:_) -> op
-#ifdef DEBUG
- [] -> panic "readUnfoldingPrimOp" -- ++ _UNPK_ str ++"::"++show (map fst tbl))
-#endif
-\end{code}
-
-Make table entries for various things:
-\begin{code}
-pcTyConNameInfo :: TyCon -> (FAST_STRING, Name)
-pcTyConNameInfo tycon
- = (getOccurrenceName tycon, WiredInTyCon tycon)
-
-pcDataConNameInfo :: TyCon -> [(FAST_STRING, Name)]
-pcDataConNameInfo tycon
- = -- slurp out its data constructors...
- [(getOccurrenceName con, WiredInVal con) | con <- getTyConDataCons tycon]
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrelFuns where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CharSeq(CSeq)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, StrictnessInfo, UpdateInfo, arityMaybe, mkArityInfo, mkUnfolding, noIdInfo, noInfo_UF, nullSpecEnv)
-import InstEnv(InstTemplate)
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import Name(Name(..))
-import NameTypes(FullName, ShortName, mkPreludeCoreName)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PlainCore(PlainCoreAtom(..), PlainCoreExpr(..))
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind(..))
-import PrimOps(PrimOp(..))
-import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance(..))
-import SrcLoc(SrcLoc)
-import TyCon(Arity(..), TyCon)
-import TyVar(TyVar, TyVarTemplate, alpha_tv, alpha_tyvar, beta_tv, beta_tyvar, delta_tv, delta_tyvar, epsilon_tv, epsilon_tyvar, gamma_tv, gamma_tyvar)
-import TyVarEnv(TyVarEnv(..))
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType(..), alpha, alpha_ty, beta, beta_ty, delta, delta_ty, epsilon, epsilon_ty, gamma, gamma_ty)
-import UniqFM(UniqFM)
-import Unique(Unique)
-class OptIdInfo a where
- noInfo :: a
- getInfo :: IdInfo -> a
- addInfo :: IdInfo -> a -> IdInfo
- ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
-class NamedThing a where
- getExportFlag :: a -> ExportFlag
- isLocallyDefined :: a -> Bool
- getOrigName :: a -> (_PackedString, _PackedString)
- getOccurrenceName :: a -> _PackedString
- getInformingModules :: a -> [_PackedString]
- getSrcLoc :: a -> SrcLoc
- getTheUnique :: a -> Unique
- hasType :: a -> Bool
- getType :: a -> UniType
- fromPreludeCore :: a -> Bool
-class Outputable a where
- ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data Bag a
-data BasicLit
-data BinderInfo
-data Class
-data ClassOp
-data GlobalSwitch
-data CoreArg a
-data CoreAtom a
-data CoreBinding a b
-data CoreCaseAlternatives a b
-data CoreCaseDefault a b
-data CoreExpr a b
-data CostCentre
-data Id
-type IdEnv a = UniqFM a
-data ArgUsage
-data ArgUsageInfo
-data ArityInfo
-data DeforestInfo
-data Demand
-data DemandInfo
-data FBConsum
-data FBProd
-data FBType
-data FBTypeInfo
-data IdInfo
-data SpecEnv
-data StrictnessInfo
-data UpdateInfo
-data InstTemplate
-data Labda a
-data Name = Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString
-data FullName
-data ShortName
-data ExportFlag
-type PlainCoreAtom = CoreAtom Id
-type PlainCoreExpr = CoreExpr Id Id
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
-data PrimOp
- = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp
-data UnfoldingDetails
-data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int | BadUnfolding
-data SrcLoc
-type Arity = Int
-data TyCon
-data TyVar
-data TyVarTemplate
-type TyVarEnv a = UniqFM a
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType = UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType
-data UniqFM a
-data Unique
-arityMaybe :: ArityInfo -> Labda Int
-mkArityInfo :: Int -> ArityInfo
-mkUnfolding :: UnfoldingGuidance -> CoreExpr Id Id -> UnfoldingDetails
-noIdInfo :: IdInfo
-noInfo_UF :: UnfoldingDetails
-nullSpecEnv :: SpecEnv
-mkPreludeCoreName :: _PackedString -> _PackedString -> FullName
-alpha_tv :: TyVarTemplate
-alpha_tyvar :: TyVar
-beta_tv :: TyVarTemplate
-beta_tyvar :: TyVar
-delta_tv :: TyVarTemplate
-delta_tyvar :: TyVar
-epsilon_tv :: TyVarTemplate
-epsilon_tyvar :: TyVar
-gamma_tv :: TyVarTemplate
-gamma_tyvar :: TyVar
-alpha :: UniType
-alpha_ty :: UniType
-beta :: UniType
-beta_ty :: UniType
-delta :: UniType
-delta_ty :: UniType
-epsilon :: UniType
-epsilon_ty :: UniType
-gLASGOW_MISC :: _PackedString
-gLASGOW_ST :: _PackedString
-gamma :: UniType
-gamma_ty :: UniType
-pRELUDE :: _PackedString
-pRELUDE_BUILTIN :: _PackedString
-pRELUDE_CORE :: _PackedString
-pRELUDE_IO :: _PackedString
-pRELUDE_LIST :: _PackedString
-pRELUDE_PRIMIO :: _PackedString
-pRELUDE_PS :: _PackedString
-pRELUDE_RATIO :: _PackedString
-pRELUDE_TEXT :: _PackedString
-pcDataCon :: Unique -> _PackedString -> _PackedString -> [TyVarTemplate] -> [(Class, UniType)] -> [UniType] -> TyCon -> SpecEnv -> Id
-pcDataTyCon :: Unique -> _PackedString -> _PackedString -> [TyVarTemplate] -> [Id] -> TyCon
-pcGenerateDataSpecs :: UniType -> SpecEnv
-pcGenerateSpecs :: Unique -> Id -> IdInfo -> UniType -> SpecEnv
-pcGenerateTupleSpecs :: Int -> UniType -> SpecEnv
-pcMiscPrelId :: Unique -> _PackedString -> _PackedString -> UniType -> IdInfo -> Id
-pcPrimTyCon :: Unique -> _PackedString -> Int -> ([PrimKind] -> PrimKind) -> TyCon
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[PrelFuns]{Help functions for prelude-related stuff}
-
-\begin{code}
-#include "HsVersions.h"
-
-module PrelFuns (
- pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
- pRELUDE_LIST, pRELUDE_TEXT, --OLD: pRELUDE_ARRAY, pRELUDE_COMPLEX,
- pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
- gLASGOW_ST, {-gLASGOW_IO,-} gLASGOW_MISC,
-
- alpha_tv, alpha, beta_tv, beta,
- gamma_tv, gamma, delta_tv, delta, epsilon_tv, epsilon,
- alpha_tyvar, alpha_ty, beta_tyvar, beta_ty,
- gamma_tyvar, gamma_ty, delta_tyvar, delta_ty,
- epsilon_tyvar, epsilon_ty,
-
- pcDataTyCon, pcPrimTyCon,
- pcDataCon, pcMiscPrelId,
- pcGenerateSpecs, pcGenerateDataSpecs, pcGenerateTupleSpecs,
-
- -- mkBuild, mkListFilter,
-
- -- re-export a few helpful things
- mkPreludeCoreName, nullSpecEnv,
-
- IdInfo, ArityInfo, DemandInfo, SpecEnv, StrictnessInfo,
- UpdateInfo, ArgUsageInfo, ArgUsage, DeforestInfo, FBTypeInfo,
- FBType, FBConsum, FBProd,
- OptIdInfo(..), -- class
- noIdInfo,
- mkArityInfo, arityMaybe,
- noInfo_UF, mkUnfolding, UnfoldingGuidance(..), UnfoldingDetails,
-
- -- and to make the interface self-sufficient...
- Outputable(..), NamedThing(..),
- ExportFlag, SrcLoc, Unique,
- Pretty(..), PprStyle, PrettyRep,
- -- urgh: because their instances go out w/ Outputable(..)
- BasicLit, CoreBinding, CoreCaseAlternatives, CoreArg,
- CoreCaseDefault, CoreExpr, CoreAtom, TyVarEnv(..),
- IdEnv(..), UniqFM,
-#ifdef DPH
- CoreParQuals,
- CoreParCommunicate,
-#endif {- Data Parallel Haskell -}
-
- PrimOp(..), -- NB: non-abstract
- PrimKind(..), -- NB: non-abstract
- Name(..), -- NB: non-abstract
- UniType(..), -- Mega-NB: non-abstract
-
- Class, ClassOp, Id, FullName, ShortName, TyCon, TyVarTemplate,
- TyVar, Arity(..), TauType(..), ThetaType(..), SigmaType(..),
- CostCentre, GlobalSwitch, Maybe, BinderInfo, PlainCoreExpr(..),
- PlainCoreAtom(..), InstTemplate, Demand, Bag
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
-#ifndef __GLASGOW_HASKELL__
- ,TAG_
-#endif
- ) where
-
-import AbsUniType ( mkDataTyCon, mkPrimTyCon,
- specialiseTy, splitType, applyTyCon,
- alpha_tv, alpha, beta_tv, beta, gamma_tv,
- gamma, alpha_tyvar, alpha_ty, beta_tyvar,
- beta_ty, gamma_tyvar, gamma_ty, delta_tv,
- delta, epsilon_tv, epsilon, delta_tyvar,
- delta_ty, epsilon_tyvar, epsilon_ty, TyVar,
- TyVarTemplate, Class, ClassOp, TyCon,
- Arity(..), ThetaType(..), TauType(..),
- SigmaType(..), UniType, InstTemplate
- IF_ATTACK_PRAGMAS(COMMA pprUniType)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar)
- )
-import Id ( mkPreludeId, mkSpecId, mkDataCon, getIdUniType,
- mkTemplateLocals, DataCon(..)
- )
-import IdInfo -- lots
-import Maybes ( Maybe(..) )
-import Name ( Name(..) )
-import NameTypes ( mkShortName, mkPreludeCoreName, ShortName, FullName )
-import Outputable
-import PlainCore
-import Pretty
-import PrimKind ( PrimKind(..) )
-import PrimOps ( PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import SrcLoc ( mkBuiltinSrcLoc, SrcLoc )
-import TysPrim ( charPrimTy, intPrimTy, doublePrimTy )
-import UniType ( UniType(..) -- **** CAN SEE THE CONSTRUCTORS ****
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Util
-\end{code}
-
-\begin{code}
-pRELUDE = SLIT("Prelude")
-pRELUDE_BUILTIN = SLIT("PreludeBuiltin")
-pRELUDE_CORE = SLIT("PreludeCore")
-pRELUDE_RATIO = SLIT("PreludeRatio")
-pRELUDE_LIST = SLIT("PreludeList")
---OLD:pRELUDE_ARRAY = SLIT("PreludeArray")
-pRELUDE_TEXT = SLIT("PreludeText")
---OLD:pRELUDE_COMPLEX = SLIT("PreludeComplex")
-pRELUDE_PRIMIO = SLIT("PreludePrimIO")
-pRELUDE_IO = SLIT("PreludeIO")
-pRELUDE_PS = SLIT("PreludePS")
-gLASGOW_ST = SLIT("PreludeGlaST")
---gLASGOW_IO = SLIT("PreludeGlaIO")
-gLASGOW_MISC = SLIT("PreludeGlaMisc")
-\end{code}
-
-\begin{code}
--- things for TyCons -----------------------------------------------------
-
-pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVarTemplate] -> [Id] -> TyCon
-pcDataTyCon key mod name tyvars cons
- = mkDataTyCon key full_name arity tyvars cons [{-no derivings-}] True
- where
- arity = length tyvars
- full_name = mkPreludeCoreName mod name
-
-pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ([PrimKind] -> PrimKind) -> TyCon
-pcPrimTyCon key name arity kind_fn
- = mkPrimTyCon key full_name arity kind_fn
- where
- full_name = mkPreludeCoreName pRELUDE_BUILTIN name
-\end{code}
-
-\begin{code}
--- things for Ids -----------------------------------------------------
-
-pcDataCon :: Unique{-DataConKey-} -> FAST_STRING -> FAST_STRING -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
-pcDataCon key mod name tyvars context arg_tys tycon specenv
- = mkDataCon key (mkPreludeCoreName mod name) tyvars context arg_tys tycon specenv
-
-pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> UniType -> IdInfo -> Id
-
-pcMiscPrelId key mod name ty info
- = mkPreludeId key (mkPreludeCoreName mod name) ty info
-\end{code}
-
-@mkBuild@ is suger for building a build !
-@mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
-@ty@ is the type of the list.
-@tv@ is always a new type variable.
-@c,n@ are Id's for the abstract cons and nil
-\begin{verbatim}
- c :: a -> b -> b
- n :: b
- v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
--- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
-\end{verbatim}
-@e@ is the object right inside the @build@
-
-\begin{code}
---LATER: mkBuild :: UniType
---LATER: -> TyVar
---LATER: -> Id
---LATER: -> Id
---LATER: -> PlainCoreExpr
---LATER: -> PlainCoreExpr
---LATER: mkBuild ty tv c n expr
---LATER: = CoApp (CoTyApp (CoVar buildId) ty)
---LATER: (CoTyLam tv (mkCoLam [c,n] expr))
---LATER: -- CoCon buildDataCon [ty] [CoTyLam tv (mkCoLam [c,n] expr)]
-\end{code}
-
-\begin{code}
---LATER: mkListFilter tys args ty ity c n exp
---LATER: = foldr CoTyLam
---LATER: (CoLam args (mkBuild ty ity c n exp))
---LATER: tys
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[PrelFuns-specialisations]{Specialisations for builtin values}
-%* *
-%************************************************************************
-
-The specialisations which exist for the builtin values must be recorded in
-their IdInfos.
-
-NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
- TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
-
-HACK: We currently use the same unique for the specialised Ids.
-
-The list @specing_types@ determines the types for which specialised
-versions are created. Note: This should correspond with the
-types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
-
-ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
-
-\begin{code}
-pcGenerateSpecs :: Unique -> Id -> IdInfo -> UniType -> SpecEnv
-pcGenerateSpecs key id info ty
- = pc_gen_specs True key id info ty
-
-pcGenerateDataSpecs :: UniType -> SpecEnv
-pcGenerateDataSpecs ty
- = pc_gen_specs False err err err ty
- where
- err = panic "PrelFuns:GenerateDataSpecs"
-
-pcGenerateTupleSpecs :: Int -> UniType -> SpecEnv
-pcGenerateTupleSpecs arity ty
- = if arity < 5 then
- pcGenerateDataSpecs ty
- else if arity == 5 then
- let
- tup5_spec jty = SpecInfo (take 5 (repeat jty))
- 0 (panic "SpecData:SpecInfo:SpecId")
- in
- mkSpecEnv (map tup5_spec (tail specing_types))
- else if arity == 19 then
- mkSpecEnv [SpecInfo (Nothing : Just doublePrimTy : take 17 (repeat Nothing))
- 0 (panic "SpecData:SpecInfo:SpecId")]
- else
- nullSpecEnv
-
-pc_gen_specs is_id key id info ty
- = mkSpecEnv spec_infos
- where
- spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
- spec_id = if is_id
- then mkSpecId key {- HACK WARNING: same unique! -}
- id spec_tys spec_ty info
- else panic "SpecData:SpecInfo:SpecId"
- in
- SpecInfo spec_tys (length ctxts) spec_id
- | spec_tys <- specialisations ]
-
- (tyvars, ctxts, _) = splitType ty
- no_tyvars = length tyvars
-
- specialisations = if no_tyvars == 0
- then []
- else tail (cross_product no_tyvars specing_types)
-
- -- N.B. tail removes fully polymorphic specialisation
-
-cross_product 0 tys = []
-cross_product 1 tys = map (:[]) tys
-cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
-
-
-specing_types = [Nothing,
- Just charPrimTy,
- Just doublePrimTy,
- Just intPrimTy ]
-\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PrelInfo (
+
+ pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
+ pRELUDE_LIST, pRELUDE_TEXT,
+ pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
+ gLASGOW_ST, gLASGOW_MISC,
+
+ -- lookup functions for built-in names, for the renamer:
+ builtinNameInfo,
+
+ -- *odd* values that need to be reached out and grabbed:
+ eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
+ packStringForCId,
+ unpackCStringId, unpackCString2Id,
+ unpackCStringAppendId, unpackCStringFoldrId,
+ integerZeroId, integerPlusOneId,
+ integerPlusTwoId, integerMinusOneId,
+
+ -----------------------------------------------------
+ -- the rest of the export list is organised by *type*
+ -----------------------------------------------------
+
+ -- type: Bool
+ boolTyCon, boolTy, falseDataCon, trueDataCon,
+
+ -- types: Char#, Char, String (= [Char])
+ charPrimTy, charTy, stringTy,
+ charPrimTyCon, charTyCon, charDataCon,
+
+ -- type: Ordering (used in deriving)
+ orderingTy, ltDataCon, eqDataCon, gtDataCon,
+
+ -- types: Double#, Double
+ doublePrimTy, doubleTy,
+ doublePrimTyCon, doubleTyCon, doubleDataCon,
+
+ -- types: Float#, Float
+ floatPrimTy, floatTy,
+ floatPrimTyCon, floatTyCon, floatDataCon,
+
+ -- types: Glasgow *primitive* arrays, sequencing and I/O
+ mkPrimIoTy, -- to typecheck "mainPrimIO" & for _ccall_s
+ realWorldStatePrimTy, realWorldStateTy{-boxed-},
+ realWorldTy, realWorldTyCon, realWorldPrimId,
+ statePrimTyCon, stateDataCon, getStatePairingConInfo,
+
+ byteArrayPrimTy,
+
+ -- types: Void# (only used within the compiler)
+ voidPrimTy, voidPrimId,
+
+ -- types: Addr#, Int#, Word#, Int
+ intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon,
+ wordPrimTyCon, wordPrimTy, wordTy, wordTyCon, wordDataCon,
+ addrPrimTyCon, addrPrimTy, addrTy, addrTyCon, addrDataCon,
+
+ -- types: Integer, Rational (= Ratio Integer)
+ integerTy, rationalTy,
+ integerTyCon, integerDataCon,
+ rationalTyCon, ratioDataCon,
+
+ -- type: Lift
+ liftTyCon, liftDataCon, mkLiftTy,
+
+ -- type: List
+ listTyCon, mkListTy, nilDataCon, consDataCon,
+
+ -- type: tuples
+ mkTupleTy, unitTy,
+
+ -- for compilation of List Comprehensions and foldr
+ foldlId, foldrId,
+ mkBuild, buildId, augmentId, appendId
+
+ -- and, finally, we must put in some (abstract) data types,
+ -- to make the interface self-sufficient
+ ) where
+
+import Ubiq
+import PrelLoop ( primOpNameInfo )
+
+-- friends:
+import PrelMods -- Prelude module names
+import PrelVals -- VALUES
+import PrimOp ( PrimOp(..), allThePrimOps )
+import PrimRep ( PrimRep(..) )
+import TysPrim -- TYPES
+import TysWiredIn
+
+-- others:
+import CmdLineOpts
+import FiniteMap
+import Id ( mkTupleCon, GenId{-instances-} )
+import Name ( Name(..) )
+import NameTypes ( mkPreludeCoreName, FullName, ShortName )
+import TyCon ( getTyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon{-instances-} )
+import Type
+import Unique -- *Key stuff
+import Util ( nOfThem, panic )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[builtinNameInfo]{Lookup built-in names}
+%* *
+%************************************************************************
+
+We have two ``builtin name funs,'' one to look up @TyCons@ and
+@Classes@, the other to look up values.
+
+\begin{code}
+builtinNameInfo :: (FAST_STRING -> Maybe Name, -- name lookup fn for values
+ FAST_STRING -> Maybe Name) -- name lookup fn for tycons/classes
+
+builtinNameInfo
+ = (init_val_lookup_fn, init_tc_lookup_fn)
+ where
+ --
+ -- values (including data constructors)
+ --
+ init_val_lookup_fn
+ = if opt_HideBuiltinNames then
+ (\ x -> Nothing)
+ else if opt_HideMostBuiltinNames then
+ lookupFM (listToFM (concat min_val_assoc_lists))
+ else
+ lookupFM (listToFM (concat val_assoc_lists))
+
+ min_val_assoc_lists -- min needed when compiling bits of Prelude
+ = [
+ concat (map pcDataConNameInfo g_con_tycons),
+ concat (map pcDataConNameInfo min_nonprim_tycon_list),
+ totally_wired_in_Ids,
+ unboxed_ops
+ ]
+
+ val_assoc_lists
+ = [
+ concat (map pcDataConNameInfo g_con_tycons),
+ concat (map pcDataConNameInfo data_tycons),
+ totally_wired_in_Ids,
+ unboxed_ops,
+ special_class_ops,
+ if opt_ForConcurrent then parallel_vals else []
+ ]
+
+ --
+ -- type constructors and classes
+ --
+ init_tc_lookup_fn
+ = if opt_HideBuiltinNames then
+ (\ x -> Nothing)
+ else if opt_HideMostBuiltinNames then
+ lookupFM (listToFM (concat min_tc_assoc_lists))
+ else
+ lookupFM (listToFM (concat tc_assoc_lists))
+
+ min_tc_assoc_lists -- again, pretty ad-hoc
+ = [
+ map pcTyConNameInfo prim_tycons,
+ map pcTyConNameInfo g_tycons,
+ map pcTyConNameInfo min_nonprim_tycon_list
+ ]
+
+ tc_assoc_lists
+ = [
+ map pcTyConNameInfo prim_tycons,
+ map pcTyConNameInfo g_tycons,
+ map pcTyConNameInfo data_tycons,
+ map pcTyConNameInfo synonym_tycons,
+ std_tycon_list,
+ std_class_list
+ ]
+
+ -- We let a lot of "non-standard" values be visible, so that we
+ -- can make sense of them in interface pragmas. It's cool, though
+ -- they all have "non-standard" names, so they won't get past
+ -- the parser in user code.
+
+
+prim_tycons
+ = [addrPrimTyCon,
+ arrayPrimTyCon,
+ byteArrayPrimTyCon,
+ charPrimTyCon,
+ doublePrimTyCon,
+ floatPrimTyCon,
+ intPrimTyCon,
+ mallocPtrPrimTyCon,
+ mutableArrayPrimTyCon,
+ mutableByteArrayPrimTyCon,
+ synchVarPrimTyCon,
+ realWorldTyCon,
+ stablePtrPrimTyCon,
+ statePrimTyCon,
+ wordPrimTyCon
+ ]
+
+g_tycons
+ = mkFunTyCon : g_con_tycons
+
+g_con_tycons
+ = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..32] ]
+
+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 ]
+
+data_tycons
+ = [addrTyCon,
+ boolTyCon,
+-- byteArrayTyCon,
+ charTyCon,
+ orderingTyCon,
+ doubleTyCon,
+ floatTyCon,
+ intTyCon,
+ integerTyCon,
+ liftTyCon,
+ mallocPtrTyCon,
+-- mutableArrayTyCon,
+-- mutableByteArrayTyCon,
+ ratioTyCon,
+ return2GMPsTyCon,
+ returnIntAndGMPTyCon,
+ stablePtrTyCon,
+ stateAndAddrPrimTyCon,
+ stateAndArrayPrimTyCon,
+ stateAndByteArrayPrimTyCon,
+ stateAndCharPrimTyCon,
+ stateAndDoublePrimTyCon,
+ stateAndFloatPrimTyCon,
+ stateAndIntPrimTyCon,
+ stateAndMallocPtrPrimTyCon,
+ stateAndMutableArrayPrimTyCon,
+ stateAndMutableByteArrayPrimTyCon,
+ stateAndSynchVarPrimTyCon,
+ stateAndPtrPrimTyCon,
+ stateAndStablePtrPrimTyCon,
+ stateAndWordPrimTyCon,
+ stateTyCon,
+ wordTyCon
+ ]
+
+synonym_tycons
+ = [primIoTyCon,
+ rationalTyCon,
+ stTyCon,
+ stringTyCon]
+
+
+totally_wired_in_Ids
+ = [(SLIT("error"), WiredInVal eRROR_ID),
+ (SLIT("patError#"), WiredInVal pAT_ERROR_ID), -- occurs in i/faces
+ (SLIT("parError#"), WiredInVal pAR_ERROR_ID), -- ditto
+ (SLIT("_trace"), WiredInVal tRACE_ID),
+
+ -- now the foldr/build Ids, which need to be built in
+ -- because they have magic unfoldings
+ (SLIT("_build"), WiredInVal buildId),
+ (SLIT("_augment"), WiredInVal augmentId),
+ (SLIT("foldl"), WiredInVal foldlId),
+ (SLIT("foldr"), WiredInVal foldrId),
+ (SLIT("unpackAppendPS#"), WiredInVal unpackCStringAppendId),
+ (SLIT("unpackFoldrPS#"), WiredInVal unpackCStringFoldrId),
+
+ (SLIT("_runST"), WiredInVal runSTId),
+ (SLIT("_seq_"), WiredInVal seqId), -- yes, used in sequential-land, too
+ -- WDP 95/11
+ (SLIT("realWorld#"), WiredInVal realWorldPrimId)
+ ]
+
+parallel_vals
+ =[(SLIT("_par_"), WiredInVal parId),
+ (SLIT("_fork_"), WiredInVal forkId)
+#ifdef GRAN
+ ,
+ (SLIT("_parLocal_"), WiredInVal parLocalId),
+ (SLIT("_parGlobal_"), WiredInVal parGlobalId)
+ -- Add later:
+ -- (SLIT("_parAt_"), WiredInVal parAtId)
+ -- (SLIT("_parAtForNow_"), WiredInVal parAtForNowId)
+ -- (SLIT("_copyable_"), WiredInVal copyableId)
+ -- (SLIT("_noFollow_"), WiredInVal noFollowId)
+#endif {-GRAN-}
+ ]
+
+special_class_ops
+ = let
+ swizzle_over (str, key)
+ = (str, ClassOpName key bottom1 str bottom2)
+
+ bottom1 = panic "PrelInfo.special_class_ops:class"
+ bottom2 = panic "PrelInfo.special_class_ops:tag"
+ in
+ map swizzle_over
+ [ (SLIT("fromInt"), fromIntClassOpKey),
+ (SLIT("fromInteger"), fromIntegerClassOpKey),
+ (SLIT("fromRational"), fromRationalClassOpKey),
+ (SLIT("enumFrom"), enumFromClassOpKey),
+ (SLIT("enumFromThen"), enumFromThenClassOpKey),
+ (SLIT("enumFromTo"), enumFromToClassOpKey),
+ (SLIT("enumFromThenTo"),enumFromThenToClassOpKey),
+ (SLIT("=="), eqClassOpKey),
+ (SLIT(">="), geClassOpKey),
+ (SLIT("-"), negateClassOpKey)
+ ]
+
+unboxed_ops
+ = map primOpNameInfo allThePrimOps
+ -- plus some of the same ones but w/ different names ...
+ ++ map fn funny_name_primops
+ where
+ fn (op,s) = case (primOpNameInfo op) of (_,n) -> (s,n)
+
+funny_name_primops
+ = [(IntAddOp, SLIT("+#")),
+ (IntSubOp, SLIT("-#")),
+ (IntMulOp, SLIT("*#")),
+ (IntGtOp, SLIT(">#")),
+ (IntGeOp, SLIT(">=#")),
+ (IntEqOp, SLIT("==#")),
+ (IntNeOp, SLIT("/=#")),
+ (IntLtOp, SLIT("<#")),
+ (IntLeOp, SLIT("<=#")),
+ (DoubleAddOp, SLIT("+##")),
+ (DoubleSubOp, SLIT("-##")),
+ (DoubleMulOp, SLIT("*##")),
+ (DoubleDivOp, SLIT("/##")),
+ (DoublePowerOp, SLIT("**##")),
+ (DoubleGtOp, SLIT(">##")),
+ (DoubleGeOp, SLIT(">=##")),
+ (DoubleEqOp, SLIT("==##")),
+ (DoubleNeOp, SLIT("/=##")),
+ (DoubleLtOp, SLIT("<##")),
+ (DoubleLeOp, SLIT("<=##"))]
+
+
+std_tycon_list
+ = let
+ swizzle_over (mod, nm, key, arity, is_data)
+ = let
+ fname = mkPreludeCoreName mod nm
+ in
+ (nm, TyConName key fname arity is_data (panic "std_tycon_list:data_cons"))
+ in
+ map swizzle_over
+ [(SLIT("PreludeMonadicIO"), SLIT("IO"), iOTyConKey, 1, False)
+ ]
+
+std_class_list
+ = let
+ swizzle_over (str, key)
+ = (str, ClassName key (mkPreludeCoreName pRELUDE_CORE str) (panic "std_class_list:ops"))
+ in
+ map swizzle_over
+ [(SLIT("Eq"), eqClassKey),
+ (SLIT("Ord"), ordClassKey),
+ (SLIT("Num"), numClassKey),
+ (SLIT("Real"), realClassKey),
+ (SLIT("Integral"), integralClassKey),
+ (SLIT("Fractional"), fractionalClassKey),
+ (SLIT("Floating"), floatingClassKey),
+ (SLIT("RealFrac"), realFracClassKey),
+ (SLIT("RealFloat"), realFloatClassKey),
+ (SLIT("Ix"), ixClassKey),
+ (SLIT("Enum"), enumClassKey),
+ (SLIT("Show"), showClassKey),
+ (SLIT("Read"), readClassKey),
+ (SLIT("Monad"), monadClassKey),
+ (SLIT("MonadZero"), monadZeroClassKey),
+ (SLIT("Binary"), binaryClassKey),
+ (SLIT("_CCallable"), cCallableClassKey),
+ (SLIT("_CReturnable"), cReturnableClassKey)
+ ]
+
+\end{code}
+
+Make table entries for various things:
+\begin{code}
+pcTyConNameInfo :: TyCon -> (FAST_STRING, Name)
+pcTyConNameInfo tc = (getOccurrenceName tc, WiredInTyCon tc)
+
+pcDataConNameInfo :: TyCon -> [(FAST_STRING, Name)]
+pcDataConNameInfo tycon
+ = -- slurp out its data constructors...
+ [ (getOccurrenceName con, WiredInVal con) | con <- getTyConDataCons tycon ]
+\end{code}
--- /dev/null
+Breaks the PrelVal loop and the PrelInfo loop caused by primOpNameInfo.
+
+\begin{code}
+interface PrelLoop where
+
+import PreludePS ( _PackedString )
+
+import Class ( GenClass )
+import CoreUnfold ( mkMagicUnfolding, UnfoldingDetails )
+import IdUtils ( primOpNameInfo )
+import Name ( Name )
+import NameTypes ( mkPreludeCoreName, FullName )
+import PrimOp ( PrimOp )
+import Type ( mkSigmaTy, mkFunTys, GenType )
+import TyVar ( GenTyVar )
+import Unique ( Unique )
+import Usage ( GenUsage )
+
+mkMagicUnfolding :: Unique -> UnfoldingDetails
+mkPreludeCoreName :: _PackedString -> _PackedString -> FullName
+mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b
+mkFunTys :: [GenType a b] -> GenType a b -> GenType a b
+
+primOpNameInfo :: PrimOp -> (_PackedString, Name)
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[PrelMods]{Definitions of prelude modules}
+
+The strings identify built-in prelude modules. They are
+defined here so as to avod
+\begin{code}
+#include "HsVersions.h"
+
+module PrelMods (
+ pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
+ pRELUDE_LIST, pRELUDE_TEXT,
+ pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
+ gLASGOW_ST, gLASGOW_MISC,
+ pRELUDE_FB
+ ) where
+
+CHK_Ubiq() -- debugging consistency check
+\end{code}
+
+
+\begin{code}
+gLASGOW_MISC = SLIT("PreludeGlaMisc")
+gLASGOW_ST = SLIT("PreludeGlaST")
+pRELUDE = SLIT("Prelude")
+pRELUDE_BUILTIN = SLIT("PreludeBuiltin")
+pRELUDE_CORE = SLIT("PreludeCore")
+pRELUDE_FB = SLIT("PreludeFoldrBuild")
+pRELUDE_IO = SLIT("PreludeIO")
+pRELUDE_LIST = SLIT("PreludeList")
+pRELUDE_PRIMIO = SLIT("PreludePrimIO")
+pRELUDE_PS = SLIT("PreludePS")
+pRELUDE_RATIO = SLIT("PreludeRatio")
+pRELUDE_TEXT = SLIT("PreludeText")
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrelVals where
-import CoreSyn(CoreExpr)
-import Id(Id)
-import PreludePS(_PackedString)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique)
-aBSENT_ERROR_ID :: Id
-appendId :: Id
-augmentId :: Id
-buildId :: Id
-eRROR_ID :: Id
-errorTy :: UniType
-foldlId :: Id
-foldrId :: Id
-forkId :: Id
-integerMinusOneId :: Id
-integerPlusOneId :: Id
-integerPlusTwoId :: Id
-integerZeroId :: Id
-mkBuild :: UniType -> TyVar -> Id -> Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id
-mkFoldl :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
-mkFoldr :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
-pAR_ERROR_ID :: Id
-pAT_ERROR_ID :: Id
-pRELUDE_FB :: _PackedString
-packStringForCId :: Id
-parId :: Id
-pc_bottoming_Id :: Unique -> _PackedString -> _PackedString -> UniType -> Id
-realWorldPrimId :: Id
-runSTId :: Id
-seqId :: Id
-tRACE_ID :: Id
-unpackCString2Id :: Id
-unpackCStringAppendId :: Id
-unpackCStringFoldrId :: Id
-unpackCStringId :: Id
-voidPrimId :: Id
-
module PrelVals where
-import PrelFuns -- help functions, types and things
-import BasicLit ( mkMachInt, BasicLit(..), PrimKind )
+import Ubiq
+import IdLoop ( UnfoldingGuidance(..) )
+import PrelLoop
+
+-- friends:
+import PrelMods
import TysPrim
import TysWiredIn
-#ifdef DPH
-import TyPod ( mkPodNTy ,mkPodTy )
-import TyProcs ( mkProcessorTy )
-#endif {- Data Parallel Haskell -}
-
-#ifndef DPH
-import AbsUniType
-import Id ( mkTemplateLocals, mkTupleCon, getIdUniType,
- mkSpecId
- )
-#else
-import AbsUniType ( mkSigmaTy, mkDictTy, mkTyVarTy , SigmaType(..),
- applyTyCon, splitType, specialiseTy
- )
-import Id ( mkTemplateLocals, mkTupleCon, getIdUniType,
- mkSpecId, mkProcessorCon
- )
-#endif {- Data Parallel Haskell -}
-import IdInfo
-
-import Maybes ( Maybe(..) )
-import PlainCore -- to make unfolding templates
-import Unique -- *Key things
-import Util
+
+-- others:
+import CoreSyn -- quite a bit
+--import CoreUnfold ( UnfoldingGuidance(..), mkMagicUnfolding )
+import IdInfo -- quite a bit
+import Literal ( mkMachInt )
+--import NameTypes ( mkPreludeCoreName )
+import PrimOp ( PrimOp(..) )
+import SpecEnv ( SpecEnv(..), nullSpecEnv )
+--import Type ( mkSigmaTy, mkFunTys, GenType(..) )
+import TyVar ( alphaTyVar, betaTyVar )
+import Unique -- lots of *Keys
+import Util ( panic )
+
+-- only used herein:
+mkPreludeId = panic "PrelVals:Id.mkPreludeId"
+mkSpecId = panic "PrelVals:Id.mkSpecId"
+mkTemplateLocals = panic "PrelVals:Id.mkTemplateLocals"
+specialiseTy = panic "PrelVals:specialiseTy"
+
+pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
+
+pcMiscPrelId key mod name ty info
+ = mkPreludeId key (mkPreludeCoreName mod name) ty info
\end{code}
%************************************************************************
aBSENT_ERROR_ID
= pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
- (mkSigmaTy [alpha_tv] [] alpha)
+ (mkSigmaTy [alphaTyVar] [] alphaTy)
pAR_ERROR_ID
= pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
- (mkSigmaTy [alpha_tv] [] alpha) noIdInfo
+ (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
-errorTy :: UniType
-errorTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) alpha)
+errorTy :: Type
+errorTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
\end{code}
We want \tr{_trace} (NB: name not in user namespace) to be wired in
= pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy
(noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
where
- traceTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) (UniFun alpha alpha))
+ traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-{- OLD:
-int2IntegerId
- = pcMiscPrelId int2IntegerIdKey pRELUDE_BUILTIN SLIT("_int2Integer")
- (UniFun intTy integerTy)
- noIdInfo
--}
-
---------------------------------------------------------------------
-
packStringForCId
= pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
- (UniFun stringTy byteArrayPrimTy) noIdInfo
+ (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
--------------------------------------------------------------------
unpackCStringId
= pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
- (addrPrimTy{-a char *-} `UniFun` stringTy) noIdInfo
+ (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
-- Andy says:
--- (UniFun addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
+-- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
-- but I don't like wired-in IdInfos (WDP)
unpackCString2Id -- for cases when a string has a NUL in it
= pcMiscPrelId unpackCString2IdKey pRELUDE_BUILTIN SLIT("unpackPS2#")
- (addrPrimTy{-a char *-}
- `UniFun` (intPrimTy -- length
- `UniFun` stringTy)) noIdInfo
-
+ (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
+ noIdInfo
--------------------------------------------------------------------
unpackCStringAppendId
= pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#")
- (addrPrimTy{-a "char *" pointer-}
- `UniFun` (stringTy
- `UniFun` stringTy)) ((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("unpackAppendPS#"))
- `addInfo` mkArityInfo 2)
-
+ (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
+ ((noIdInfo
+ `addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey)
+ `addInfo` mkArityInfo 2)
+
unpackCStringFoldrId
= pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
- (mkSigmaTy [alpha_tv] []
- (addrPrimTy{-a "char *" pointer-}
- `UniFun` ((charTy `UniFun` (alpha `UniFun` alpha))
- `UniFun` (alpha
- `UniFun` alpha)))) ((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("unpackFoldrPS#"))
- `addInfo` mkArityInfo 3)
+ (mkSigmaTy [alphaTyVar] []
+ (mkFunTys [addrPrimTy{-a "char *" pointer-},
+ mkFunTys [charTy, alphaTy] alphaTy,
+ alphaTy]
+ alphaTy))
+ ((noIdInfo
+ `addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey)
+ `addInfo` mkArityInfo 3)
\end{code}
OK, this is Will's idea: we should have magic values for Integers 0,
%* *
%************************************************************************
-In the definitions that follow, we use the @TyVar@-based
-alpha/beta/gamma types---not the usual @TyVarTemplate@ ones.
-
-This is so the @TyVars@ in the @CoTyLams@ (@alpha_tyvar@, etc) match
-up with those in the types of the {\em lambda-bound} template-locals
-we create (using types @alpha_ty@, etc.).
-
\begin{code}
--------------------------------------------------------------------
-- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to
-}
seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (alpha `UniFun` (beta `UniFun` beta)))
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
where
[x, y, z]
= mkTemplateLocals [
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} intPrimTy
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
]
seq_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [x, y] (
- CoCase (CoPrim SeqOp [alpha_ty] [CoVarAtom x]) (
- CoPrimAlts
- [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
- (CoBindDefault z (CoVar y))))))
+ = mkLam [alphaTyVar, betaTyVar] [x, y] (
+ Case (Prim SeqOp [TyArg alphaTy, VarArg x]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
--------------------------------------------------------------------
-- parId :: "_par_", also used w/ GRIP, etc.
-}
parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (alpha `UniFun` (beta `UniFun` beta)))
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
where
[x, y, z]
= mkTemplateLocals [
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} intPrimTy
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
]
par_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [x, y] (
- CoCase (CoPrim ParOp [alpha_ty] [CoVarAtom x]) (
- CoPrimAlts
- [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
- (CoBindDefault z (CoVar y))))))
+ = mkLam [alphaTyVar, betaTyVar] [x, y] (
+ Case (Prim ParOp [TyArg alphaTy, VarArg x]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
-- forkId :: "_fork_", for *required* concurrent threads
{-
_fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
-}
forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (alpha `UniFun` (beta `UniFun` beta)))
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
where
[x, y, z]
= mkTemplateLocals [
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} intPrimTy
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
]
fork_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [x, y] (
- CoCase (CoPrim ForkOp [alpha_ty] [CoVarAtom x]) (
- CoPrimAlts
- [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)]
- (CoBindDefault z (CoVar y))))))
+ = mkLam [alphaTyVar, betaTyVar] [x, y] (
+ Case (Prim ForkOp [TyArg alphaTy, VarArg x]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
\end{code}
#ifdef GRAN
parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
where
[w, x, y, z]
= mkTemplateLocals [
{-w-} intPrimTy,
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} beta_ty
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} betaTy
]
parLocal_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [w, x, y] (
- CoCase (CoPrim ParLocalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
- CoAlgAlts
- [(liftDataCon, [z], CoVar z)]
- (CoNoDefault)))))
+ = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
+ Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
+ AlgAlts
+ [(liftDataCon, [z], Var z)]
+ (NoDefault)))
parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
- (mkSigmaTy [alpha_tv, beta_tv] []
- (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta))))
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy,alphaTy,betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
where
[w, x, y, z]
= mkTemplateLocals [
{-w-} intPrimTy,
- {-x-} alpha_ty,
- {-y-} beta_ty,
- {-z-} beta_ty
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} betaTy
]
parGlobal_template
- = CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (mkCoLam [w, x, y] (
- CoCase (CoPrim ParGlobalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) (
- CoAlgAlts
- [(liftDataCon, [z], CoVar z)]
- (CoNoDefault)))))
+ = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
+ Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
+ AlgAlts
+ [(liftDataCon, [z], Var z)]
+ (NoDefault)))
#endif {-GRAN-}
\end{code}
-\begin{code}
-#ifdef DPH
-vectorMapId = pcChooseToKnowId vectorMapU pRELUDE "vectorMap"
- (mkSigmaTy [alpha_tv, beta_tv , gamma_tv]
- [(pidClass,alpha)]
- ((beta `UniFun` gamma) `UniFun`
- ((mkPodTy (mkProcessorTy [alpha] beta)) `UniFun`
- (mkPodTy (mkProcessorTy [alpha] gamma)))))
- (panic "vectorMap:unfolding")--ToDo:DPH: (mkUnfoldTemplate vector_map_template)
- [(2,"","")]
- where
-{-
-vectorMap fn vec = << (|x;fn y|) | (|x;y|) <<- vec >>
-
-Simplified :
-vectorMap :: for all a.83, b.82, c.86. <Pid a.83>
- -> (b.82 -> c.86)
- -> <<a.83;b.82>>
- -> <<a.83;c.86>>
-vectorMap =
- /\ t83 t82 o86 -> \ dict.127 ->
- let
- vecMap.128 =
- \ fn.129 vec.130 ->
- << let si.133 = fn.129 ds.132 in
- let
- si.134 =
- (fromDomain t82)
- dict.127 ((toDomain t82) dict.127 ds.131)
- in MkProcessor1! Integer o86 si.134 si.133 |
- (| ds.131 ; ds.132 |) <<- vec.130 >>
- in vecMap.128
-
- NOTE : no need to bother with overloading in class Pid; because the result
- PID (si.133) is wrapped in fromDomain.toDomain == id . Therefore we
- use the simplification below.
-
-Simplified:
-vectorMap ::
- for all d.83, e.82, f.86.
- <Pid e.82> -> (d.83 -> f.86) -> <<e.82;d.83>> -> <<e.82;f.86>>
-vectorMap =
- /\ t83 t82 o86 -> \ dict.127 fn.129 vec.130 ->
- << MkProcessor1! Integer o86 ds.131 (fn.129 ds.132) |
- (| ds.131 ; ds.132 |) <<- vec.130 >>
--}
-
- vector_map_template
- = let
- [dict,fn,vec,ds131,ds132]
- = mkTemplateLocals
- [mkDictTy pidClass alpha_ty,
- beta_ty `UniFun` gamma_ty,
- mkPodTy (mkProcessorTy [alpha_ty] beta_ty),
- integerTy,
- beta_ty]
- in
- CoTyLam alpha_tyvar
- (CoTyLam beta_tyvar
- (CoTyLam gamma_tyvar
- (mkCoLam [dict,fn,vec]
- (CoZfExpr
- (CoCon (mkProcessorCon 1)
- [integerTy,mkTyVarTy gamma_tyvar]
- [CoVar ds131,
- (CoApp (CoVar fn) (CoVar ds132))])
- (CoDrawnGen [ds131] ds132 (CoVar vec)) ))))
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DPH
--- A function used during podization that produces an index POD for a given
--- POD as argument.
-
-primIfromPodNSelectorId :: Int -> Int -> Id
-primIfromPodNSelectorId i n
- = pcMiscPrelId
- podSelectorIdKey
- pRELUDE_BUILTIN
- ("prim"++ show i ++ "fromPod" ++ show n ++ "Selector")
- (UniFun
- (mkPodNTy n alpha)
- (mkPodNTy n alpha))
- noIdInfo
-#endif {- Data Parallel Haskell -}
-\end{code}
-
%************************************************************************
%* *
\subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
readParen :: Bool -> ReadS a -> ReadS a
lex :: ReadS String
-\begin{code}
-{- OLD:
-readS_ty :: UniType -> UniType
-readS_ty ty
- = UniFun stringTy (mkListTy (mkTupleTy 2 [ty, stringTy]))
-
-showS_ty :: UniType
-showS_ty = UniFun stringTy stringTy
--}
-\end{code}
-
-\begin{code}
-{- OLD:
-showSpaceId = pcMiscPrelId showSpaceIdKey pRELUDE_TEXT SLIT("_showSpace")
- showS_ty
- noIdInfo
-
-showParenId = pcMiscPrelId showParenIdKey pRELUDE_TEXT SLIT("showParen")
- (boolTy `UniFun` (showS_ty `UniFun` showS_ty))
- noIdInfo
-
-readParenId = pcMiscPrelId readParenIdKey pRELUDE_TEXT SLIT("readParen")
- (mkSigmaTy [alpha_tv] [] (
- boolTy `UniFun` (
- (readS_ty alpha) `UniFun` (readS_ty alpha))))
- noIdInfo
-
-lexId = pcMiscPrelId lexIdKey pRELUDE_TEXT SLIT("lex")
- (readS_ty (mkListTy charTy))
- noIdInfo
--}
-\end{code}
-
%************************************************************************
%* *
\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
-- forall a. (forall s. (_State s -> (a, _State s))) -> a
_runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
- (r :: a, wild :: _State _RealWorld) -> r
+ (r :: a, wild :: _State _RealWorld) -> r
\end{verbatim}
We unfold always, just for simplicity:
\begin{code}
runSTId
= pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
where
- s_tv = beta_tv
- s = beta
+ s_tv = betaTyVar
+ s = betaTy
st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a)
run_ST_ty
- = mkSigmaTy [alpha_tv] [] (st_ty alpha `UniFun` alpha)
+ = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy)
-- NB: rank-2 polymorphism! (forall inside the st_ty...)
id_info
= noIdInfo
`addInfo` mkArityInfo 1
- `addInfo` mkStrictnessInfo [WwStrict] Nothing
+ `addInfo` mkStrictnessInfo [WwStrict] Nothing
`addInfo` mkArgUsageInfo [ArgUsage 1]
-- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
-- see example below
{- OUT:
[m, t, r, wild]
= mkTemplateLocals [
- {-m-} st_ty alpha_ty,
+ {-m-} st_ty alphaTy,
{-t-} realWorldStateTy,
- {-r-} alpha_ty,
+ {-r-} alphaTy,
{-_-} realWorldStateTy
]
run_ST_template
- = CoTyLam alpha_tyvar
- (mkCoLam [m] (
- CoLet (CoNonRec t (CoCon stateDataCon [realWorldTy] [CoVarAtom realWorldPrimId])) (
- CoCase (CoApp (mkCoTyApp (CoVar m) realWorldTy) (CoVarAtom t)) (
- CoAlgAlts
- [(mkTupleCon 2, [r, wild], CoVar r)]
- CoNoDefault))))
+ = mkLam [alphaTyVar] [m] (
+ Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
+ Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
+ AlgAlts
+ [(mkTupleCon 2, [r, wild], Var r)]
+ NoDefault)))
-}
\end{code}
All calls to @f@ will share a {\em single} array! End SLPJ 95/04.
@realWorld#@ used to be a magic literal, \tr{void#}. If things get
-nasty as-is, change it back to a literal (@BasicLit@).
+nasty as-is, change it back to a literal (@Literal@).
\begin{code}
realWorldPrimId
= pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
%************************************************************************
\begin{code}
-{- NO:
-rangeComplaint_Ix_IntId
- = pcMiscPrelId rangeComplaintIdKey pRELUDE_BUILTIN SLIT("_rangeComplaint_Ix_Int") my_ty id_info
- where
- my_ty
- = mkSigmaTy [alpha_tv] [] (
- intPrimTy `UniFun` (
- intPrimTy `UniFun` (
- intPrimTy `UniFun` alpha)))
- id_info
- = noIdInfo
- `addInfo` mkArityInfo 3
- `addInfo` mkBottomStrictnessInfo
--}
-\end{code}
-
-\begin{code}
buildId
= pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
- ((((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("build"))
+ ((((noIdInfo
+ `addInfo_UF` mkMagicUnfolding buildIdKey)
`addInfo` mkStrictnessInfo [WwStrict] Nothing)
`addInfo` mkArgUsageInfo [ArgUsage 2])
- `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
+ `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
-- cheating, but since _build never actually exists ...
where
-- The type of this strange object is:
-- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
- buildTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun` (mkListTy alpha))
+ buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
where
- buildUniTy = mkSigmaTy [beta_tv] []
- ((alpha `UniFun` (beta `UniFun` beta))
- `UniFun` (beta `UniFun` beta))
+ build_ty = mkSigmaTy [betaTyVar] []
+ (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
\end{code}
@mkBuild@ is sugar for building a build!
@e@ is the object right inside the @build@
\begin{code}
-mkBuild :: UniType
+mkBuild :: Type
-> TyVar
-> Id
-> Id
-> Id
- -> PlainCoreExpr -- template
- -> PlainCoreExpr -- template
+ -> CoreExpr -- template
+ -> CoreExpr -- template
mkBuild ty tv c n g expr
- = CoLet (CoNonRec g (CoTyLam tv (mkCoLam [c,n] expr)))
- (CoApp (mkCoTyApp (CoVar buildId) ty) (CoVarAtom g))
+ = Let (NonRec g (mkLam [tv] [c,n] expr))
+ (App (mkTyApp (Var buildId) [ty]) (VarArg g))
\end{code}
\begin{code}
augmentId
- = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_augment") augmentTy
- (((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("augment"))
+ = pcMiscPrelId augmentIdKey pRELUDE_CORE SLIT("_augment") augmentTy
+ (((noIdInfo
+ `addInfo_UF` mkMagicUnfolding augmentIdKey)
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
`addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
- -- cheating, but since _build never actually exists ...
+ -- cheating, but since _augment never actually exists ...
where
-- The type of this strange object is:
-- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
- augmentTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun`
- (mkListTy alpha `UniFun` mkListTy alpha))
+ augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
where
- buildUniTy = mkSigmaTy [beta_tv] []
- ((alpha `UniFun` (beta `UniFun` beta))
- `UniFun` (beta `UniFun` beta))
+ aug_ty = mkSigmaTy [betaTyVar] []
+ (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
\end{code}
-mkFoldr ty_a ty_b [x,y...] => foldr ty_a ty_b x y ..
-
\begin{code}
foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
foldrTy idInfo
where
foldrTy =
- mkSigmaTy [alpha_tv, beta_tv] []
- ((alpha `UniFun` (beta `UniFun` beta))
- `UniFun` (beta
- `UniFun` ((mkListTy alpha)
- `UniFun` beta)))
-
- idInfo = (((((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("foldr"))
+ mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
+
+ idInfo = (((((noIdInfo
+ `addInfo_UF` mkMagicUnfolding foldrIdKey)
`addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
`addInfo` mkArityInfo 3)
`addInfo` mkUpdateInfo [2,2,1])
- `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
-
-mkFoldr a b f z xs = foldl CoApp
- (mkCoTyApps (CoVar foldrId) [a, b])
- [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
+ `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
foldlTy idInfo
where
foldlTy =
- mkSigmaTy [alpha_tv, beta_tv] []
- ((alpha `UniFun` (beta `UniFun` alpha))
- `UniFun` (alpha
- `UniFun` ((mkListTy beta)
- `UniFun` alpha)))
-
- idInfo = (((((noIdInfo
- `addInfo_UF` mkMagicUnfolding SLIT("foldl"))
+ mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, alphaTy, mkListTy betaTy] alphaTy)
+
+ idInfo = (((((noIdInfo
+ `addInfo_UF` mkMagicUnfolding foldlIdKey)
`addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
`addInfo` mkArityInfo 3)
`addInfo` mkUpdateInfo [2,2,1])
- `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
-
-mkFoldl a b f z xs = foldl CoApp
- (mkCoTyApps (CoVar foldlId) [a, b])
- [CoVarAtom f,CoVarAtom z,CoVarAtom xs]
+ `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
-- A bit of magic goes no here. We translate appendId into ++,
-- you have to be carefull when you actually compile append:
-- {- unfold augment -}
-- = foldr (:) ys xs
-- {- fold foldr to append -}
--- = ys `appendId` xs
+-- = ys `appendId` xs
-- = ys ++ xs -- ugg!
-- *BUT* you want (++) and not _append in your interfaces.
--
= pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
where
appendTy =
- (mkSigmaTy [alpha_tv] []
- ((mkListTy alpha) `UniFun` ((mkListTy alpha) `UniFun` (mkListTy alpha))))
- idInfo = (((noIdInfo
+ (mkSigmaTy [alphaTyVar] []
+ (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
+ idInfo = (((noIdInfo
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
`addInfo` mkArityInfo 2)
`addInfo` mkUpdateInfo [1,2])
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[PrelUtils-specialisations]{Specialisations for builtin values}
+%* *
+%************************************************************************
+
+The specialisations which exist for the builtin values must be recorded in
+their IdInfos.
-pRELUDE_FB = SLIT("PreludeFoldrBuild")
+NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
+ TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
+
+HACK: We currently use the same unique for the specialised Ids.
+
+The list @specing_types@ determines the types for which specialised
+versions are created. Note: This should correspond with the
+types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
+
+ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
+
+\begin{code}
+pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv
+pcGenerateSpecs key id info ty
+ = nullSpecEnv
+
+{- LATER:
+
+pc_gen_specs True key id info ty
+
+pc_gen_specs is_id key id info ty
+ = mkSpecEnv spec_infos
+ where
+ spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
+ spec_id = if is_id
+ then mkSpecId key {- HACK WARNING: same unique! -}
+ id spec_tys spec_ty info
+ else panic "SpecData:SpecInfo:SpecId"
+ in
+ SpecInfo spec_tys (length ctxts) spec_id
+ | spec_tys <- specialisations ]
+
+ (tyvars, ctxts, _) = splitSigmaTy ty
+ no_tyvars = length tyvars
+
+ specialisations = if no_tyvars == 0
+ then []
+ else tail (cross_product no_tyvars specing_types)
+
+ -- N.B. tail removes fully polymorphic specialisation
+
+cross_product 0 tys = []
+cross_product 1 tys = map (:[]) tys
+cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
+
+
+specing_types = [Nothing,
+ Just charPrimTy,
+ Just doublePrimTy,
+ Just intPrimTy ]
+-}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrimKind where
-import Id(DataCon(..), Id)
-import Outputable(Outputable)
-import TyCon(TyCon)
-import UniType(UniType)
-type DataCon = Id
-data Id
-data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
-data TyCon
-data UniType
-getKindInfo :: PrimKind -> ([Char], UniType, TyCon)
-getKindSize :: PrimKind -> Int
-guessPrimKind :: [Char] -> PrimKind
-isFloatingKind :: PrimKind -> Bool
-isFollowableKind :: PrimKind -> Bool
-retKindSize :: Int
-separateByPtrFollowness :: (a -> PrimKind) -> [a] -> ([a], [a])
-showPrimKind :: PrimKind -> [Char]
-instance Eq PrimKind
-instance Ord PrimKind
-instance Outputable PrimKind
-
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1992-1995
-%
-\section[PrimKind]{Primitive machine-level kinds of things.}
-
-At various places in the back end, we want to be to tag things with a
-``primitive kind''---i.e., the machine-manipulable implementation
-types.
-
-\begin{code}
-#include "HsVersions.h"
-
-module PrimKind (
- PrimKind(..),
- separateByPtrFollowness, isFollowableKind, isFloatingKind,
- getKindSize, retKindSize,
- getKindInfo, -- ToDo: DIE DIE DIE DIE DIE
- showPrimKind,
- guessPrimKind,
-
- -- and to make the interface self-sufficient...
- Id, DataCon(..), TyCon, UniType
- ) where
-
-IMPORT_Trace
-
-#ifdef DPH
-import TyPod
-#endif {- Data Parallel Haskell -}
-
-import AbsUniType -- we use more than I want to type in...
-import Id ( Id, DataCon(..) )
-import Outputable -- class for printing, forcing
-import TysPrim
-import Pretty -- pretty-printing code
-import Util
-
-#ifndef DPH
-#include "../../includes/GhcConstants.h"
-#else
-#include "../dphsystem/imports/DphConstants.h"
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrimKind-datatype]{The @PrimKind@ datatype}
-%* *
-%************************************************************************
-
-\begin{code}
-data PrimKind
- = -- These pointer-kinds are all really the same, but we keep
- -- them separate for documentation purposes.
- PtrKind -- Pointer to a closure; a ``word''.
- | CodePtrKind -- Pointer to code
- | DataPtrKind -- Pointer to data
- | RetKind -- Pointer to code or data (return vector or code pointer)
- | InfoPtrKind -- Pointer to info table (DPH only?)
- | CostCentreKind -- Pointer to a cost centre
-
- | CharKind -- Machine characters
- | IntKind -- integers (at least 32 bits)
- | WordKind -- ditto (but *unsigned*)
- | AddrKind -- addresses ("C pointers")
- | FloatKind -- floats
- | DoubleKind -- doubles
-
- | MallocPtrKind -- This has to be a special kind because ccall
- -- generates special code when passing/returning
- -- one of these. [ADR]
-
- | StablePtrKind -- We could replace this with IntKind but maybe
- -- there's some documentation gain from having
- -- it special? [ADR]
-
- | ArrayKind -- Primitive array of Haskell pointers
- | ByteArrayKind -- Primitive array of bytes (no Haskell pointers)
-
- | VoidKind -- Occupies no space at all!
- -- (Primitive states are mapped onto this)
-#ifdef DPH
- | PodNKind Int PrimKind
-#endif {- Data Parallel Haskell -}
- deriving (Eq, Ord)
- -- Kinds are used in PrimTyCons, which need both Eq and Ord
- -- Text is needed for derived-Text on PrimitiveOps
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrimKind-predicates]{Follow-ness, sizes, and such---on @PrimitiveKinds@}
-%* *
-%************************************************************************
-
-Whether or not the thing is a pointer that the garbage-collector
-should follow.
-
-Or, to put it another (less confusing) way, whether the object in
-question is a heap object.
-
-\begin{code}
-isFollowableKind :: PrimKind -> Bool
-isFollowableKind PtrKind = True
-isFollowableKind ArrayKind = True
-isFollowableKind ByteArrayKind = True
-isFollowableKind MallocPtrKind = True
-
-isFollowableKind StablePtrKind = False
--- StablePtrs aren't followable because they are just indices into a
--- table for which explicit allocation/ deallocation is required.
-
-isFollowableKind other = False
-
-separateByPtrFollowness :: (a -> PrimKind) -> [a] -> ([a], [a])
-separateByPtrFollowness kind_fun things
- = sep_things kind_fun things [] []
- -- accumulating params for follow-able and don't-follow things...
- where
- sep_things kfun [] bs us = (reverse bs, reverse us)
- sep_things kfun (t:ts) bs us
- = if (isFollowableKind . kfun) t then
- sep_things kfun ts (t:bs) us
- else
- sep_things kfun ts bs (t:us)
-\end{code}
-
-@isFloatingKind@ is used to distinguish @Double@ and @Float@ which
-cause inadvertent numeric conversions if you aren't jolly careful.
-See codeGen/CgCon:cgTopRhsCon.
-
-\begin{code}
-isFloatingKind :: PrimKind -> Bool
-isFloatingKind DoubleKind = True
-isFloatingKind FloatKind = True
-isFloatingKind other = False
-\end{code}
-
-\begin{code}
-getKindSize :: PrimKind -> Int
-getKindSize DoubleKind = DOUBLE_SIZE -- "words", of course
---getKindSize FloatKind = 1
---getKindSize CharKind = 1 -- ToDo: count in bytes?
---getKindSize ArrayKind = 1 -- Listed specifically for *documentation*
---getKindSize ByteArrayKind = 1
-
-#ifdef DPH
-getKindSize (PodNKind _ _) = panic "getKindSize: PodNKind"
-#endif {- Data Parallel Haskell -}
-
-getKindSize VoidKind = 0
-getKindSize other = 1
-
-
-retKindSize :: Int
-retKindSize = getKindSize RetKind
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrimKind-type-fns]{@PrimitiveKinds@ and @UniTypes@}
-%* *
-%************************************************************************
-
-@PrimitiveKinds@ are used in @PrimitiveOps@, for which we often need
-to reconstruct various type information. (It's slightly more
-convenient/efficient to make type info from kinds, than kinds [etc.]
-from type info.)
-
-\begin{code}
-getKindInfo ::
- PrimKind -> (String, -- tag string
- UniType, TyCon) -- prim type and tycon
-
-getKindInfo CharKind = ("Char", charPrimTy, charPrimTyCon)
-getKindInfo IntKind = ("Int", intPrimTy, intPrimTyCon)
-getKindInfo WordKind = ("Word", wordPrimTy, wordPrimTyCon)
-getKindInfo AddrKind = ("Addr", addrPrimTy, addrPrimTyCon)
-getKindInfo FloatKind = ("Float", floatPrimTy, floatPrimTyCon)
-getKindInfo DoubleKind = ("Double", doublePrimTy, doublePrimTyCon)
-#ifdef DPH
-getKindInfo k@(PodNKind d kind)
- = case kind of
- PtrKind ->(no_no, no_no, no_no, no_no, no_no, no_no)
- CharKind ->("Char.Pod"++show d, mkPodizedPodNTy d charPrimTy,
- no_no, mkPodizedPodNTy d charTy, no_no, no_no)
-
- IntKind ->("Int.Pod"++show d, mkPodizedPodNTy d intPrimTy,
- no_no, mkPodizedPodNTy d intTy, no_no , no_no)
-
- FloatKind ->("Float.Pod"++show d, mkPodizedPodNTy d floatPrimTy,
- no_no ,mkPodizedPodNTy d floatTy, no_no, no_no)
-
- DoubleKind->("Double.Pod"++show d, mkPodizedPodNTy d doublePrimTy,
- no_no, mkPodizedPodNTy d doubleTy, no_no, no_no)
- AddrKind ->("Addr.Pod"++show d, mkPodizedPodNTy d addrPrimTy,
- no_no, no_no, no_no, no_no)
- _ -> pprPanic "Found PodNKind" (ppr PprDebug k)
- where
- no_no = panic "getKindInfo: PodNKind"
-
-getKindInfo other = pprPanic "getKindInfo" (ppr PprDebug other)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrimKind-instances]{Boring instance decls for @PrimKind@}
-%* *
-%************************************************************************
-
-\begin{code}
-instance Outputable PrimKind where
-#ifdef DPH
- ppr sty (PodNKind d k) = ppBesides [ppr sty k , ppStr ".POD" , ppr sty d]
-#endif {- Data Parallel Haskell -}
- ppr sty kind = ppStr (showPrimKind kind)
-
-showPrimKind :: PrimKind -> String
-guessPrimKind :: String -> PrimKind -- a horrible "inverse" function
-
-showPrimKind PtrKind = "P_" -- short for StgPtr
-
-showPrimKind CodePtrKind = "P_" -- DEATH to StgFunPtr! (94/02/22 WDP)
- -- but aren't code pointers and function pointers different sizes
- -- on some machines (eg 80x86)? ADR
- -- Are you trying to ruin my life, or what? (WDP)
-
-showPrimKind DataPtrKind = "D_"
-showPrimKind RetKind = "StgRetAddr"
-showPrimKind InfoPtrKind = "StgInfoPtr"
-showPrimKind CostCentreKind = "CostCentre"
-showPrimKind CharKind = "StgChar"
-showPrimKind IntKind = "I_" -- short for StgInt
-showPrimKind WordKind = "W_" -- short for StgWord
-showPrimKind AddrKind = "StgAddr"
-showPrimKind FloatKind = "StgFloat"
-showPrimKind DoubleKind = "StgDouble"
-showPrimKind ArrayKind = "StgArray" -- see comment below
-showPrimKind ByteArrayKind = "StgByteArray"
-showPrimKind StablePtrKind = "StgStablePtr"
-showPrimKind MallocPtrKind = "StgPtr" -- see comment below
-showPrimKind VoidKind = "!!VOID_KIND!!"
-
-guessPrimKind "D_" = DataPtrKind
-guessPrimKind "StgRetAddr" = RetKind
-guessPrimKind "StgInfoPtr" = InfoPtrKind
-guessPrimKind "StgChar" = CharKind
-guessPrimKind "I_" = IntKind
-guessPrimKind "W_" = WordKind
-guessPrimKind "StgAddr" = AddrKind
-guessPrimKind "StgFloat" = FloatKind
-guessPrimKind "StgDouble" = DoubleKind
-guessPrimKind "StgArray" = ArrayKind
-guessPrimKind "StgByteArray" = ByteArrayKind
-guessPrimKind "StgStablePtr" = StablePtrKind
-\end{code}
-
-All local C variables of @ArrayKind@ are declared in C as type
-@StgArray@. The coercion to a more precise C type is done just before
-indexing (by the relevant C primitive-op macro).
-
-Nota Bene. There are three types associated with Malloc Pointers:
-\begin{itemize}
-\item
-@StgMallocClosure@ is the type of the thing the C world gives us.
-(This typename is hardwired into @ppr_casm_results@ in
-@PprAbsC.lhs@.)
-
-\item
-@StgMallocPtr@ is the type of the thing we give the C world.
-
-\item
-@StgPtr@ is the type of the (pointer to the) heap object which we
-pass around inside the STG machine.
-\end{itemize}
-
-It is really easy to confuse the two. (I'm not sure this choice of
-type names helps.) [ADR]
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[PrimOps]{Primitive operations (machine-level)}
+\section[PrimOp]{Primitive operations (machine-level)}
\begin{code}
#include "HsVersions.h"
-module PrimOps (
- PrimOp(..),
+module PrimOp (
+ PrimOp(..), allThePrimOps,
tagOf_PrimOp, -- ToDo: rm
- primOpNameInfo, primOpId,
- typeOfPrimOp, isCompareOp,
- primOpCanTriggerGC, primOpNeedsWrapper,
- primOpOkForSpeculation, primOpIsCheap,
- fragilePrimOp,
+ primOp_str, -- sigh
+ primOpType, isCompareOp,
PrimOpResultInfo(..),
getPrimOpResultInfo,
- HeapRequirement(..), primOpHeapReq,
+--MOVE: primOpCanTriggerGC, primOpNeedsWrapper,
+--MOVE: primOpOkForSpeculation, primOpIsCheap,
+--MOVE: fragilePrimOp,
+--MOVE: HeapRequirement(..), primOpHeapReq,
-- export for the Native Code Generator
--- primOpInfo, not exported
- PrimOpInfo(..),
+ primOpInfo, -- needed for primOpNameInfo
+ PrimOpInfo(..),
- pprPrimOp, showPrimOp,
+ pprPrimOp, showPrimOp
-- and to make the interface self-sufficient....
- PrimKind, HeapOffset, Id, Name, TyCon, UniType, TyVarTemplate
) where
-import PrelFuns -- help stuff for prelude
-import PrimKind -- most of it
+import Ubiq{-uitous-}
+
+import PrimRep -- most of it
import TysPrim
import TysWiredIn
-import AbsUniType -- lots of things
-import CLabelInfo ( identToC )
+import CStrings ( identToC )
import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
-import BasicLit ( BasicLit(..) )
-import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
-import Id -- lots
-import IdInfo -- plenty of this, too
-import Maybes ( Maybe(..) )
import NameTypes ( mkPreludeCoreName, FullName, ShortName )
-import Outputable
-import PlainCore -- all of it
+import PprStyle ( codeStyle )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import Unique
-import Util
-#ifdef DPH
-import TyPod
-#endif {- Data Parallel Haskell -}
+import TyCon ( TyCon{-instances-} )
+import Type ( getAppDataTyCon, maybeAppDataTyCon,
+ mkForAllTys, mkFunTys, applyTyCon )
+import TyVar ( alphaTyVar, betaTyVar )
+import Util ( panic#, assoc, panic{-ToDo:rm-} )
+
+glueTyArgs = panic "PrimOp:glueTyArgs"
+pprParendType = panic "PrimOp:pprParendType"
+primRepFromType = panic "PrimOp:primRepFromType"
\end{code}
%************************************************************************
%* *
-\subsection[PrimOps-datatype]{Datatype for @PrimOp@ (an enumeration)}
+\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)}
%* *
%************************************************************************
-- Int#-related ops:
-- IntAbsOp unused?? ADR
| IntAddOp | IntSubOp | IntMulOp | IntQuotOp
- | IntDivOp{-UNUSED-} | IntRemOp | IntNegOp | IntAbsOp
+ | IntRemOp | IntNegOp | IntAbsOp
-- Word#-related ops:
| AndOp | OrOp | NotOp
-- primitive ops for primitive arrays
| NewArrayOp
- | NewByteArrayOp PrimKind
+ | NewByteArrayOp PrimRep
| SameMutableArrayOp
| SameMutableByteArrayOp
| ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
- | ReadByteArrayOp PrimKind
- | WriteByteArrayOp PrimKind
- | IndexByteArrayOp PrimKind
- | IndexOffAddrOp PrimKind
- -- PrimKind can be one of {Char,Int,Addr,Float,Double}Kind.
+ | ReadByteArrayOp PrimRep
+ | WriteByteArrayOp PrimRep
+ | IndexByteArrayOp PrimRep
+ | IndexOffAddrOp PrimRep
+ -- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
-- This is just a cheesy encoding of a bunch of ops.
- -- Note that MallocPtrKind is not included -- the only way of
+ -- Note that MallocPtrRep is not included -- the only way of
-- creating a MallocPtr is with a ccall or casm.
| UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
| CCallOp FAST_STRING -- An "unboxed" ccall# to this named function
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
- [UniType] -- Unboxed argument; the state-token
+ [Type] -- Unboxed argument; the state-token
-- argument will have been put *first*
- UniType -- Return type; one of the "StateAnd<blah>#" types
+ Type -- Return type; one of the "StateAnd<blah>#" types
-- (... to be continued ... )
\end{code}
\end{pseudocode}
by
\begin{pseudocode}
-CoCase
- ( CoPrim
- (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False)
+Case
+ ( Prim
+ (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False)
-- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse
[]
[w#, sp# i#]
)
- (CoAlgAlts [ ( FloatPrimAndIoWorld,
- [f#, w#],
- CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
- ) ]
- CoNoDefault
+ (AlgAlts [ ( FloatPrimAndIoWorld,
+ [f#, w#],
+ Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
+ ) ]
+ NoDefault
)
\end{pseudocode}
Nota Bene: there are some people who find the empty list of types in
-the @CoPrim@ somewhat puzzling and would represent the above by
+the @Prim@ somewhat puzzling and would represent the above by
\begin{pseudocode}
-CoCase
- ( CoPrim
+Case
+ ( Prim
(CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False)
- -- :: /\ alpha1, alpha2 alpha3, alpha4.
+ -- :: /\ alpha1, alpha2 alpha3, alpha4.
-- alpha1 -> alpha2 -> alpha3 -> alpha4
[Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld]
[w#, sp# i#]
)
- (CoAlgAlts [ ( FloatPrimAndIoWorld,
- [f#, w#],
- CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
- ) ]
- CoNoDefault
+ (AlgAlts [ ( FloatPrimAndIoWorld,
+ [f#, w#],
+ Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
+ ) ]
+ NoDefault
)
-\end{pseudocode}
+\end{pseudocode}
But, this is a completely different way of using @CCallOp@. The most
major changes required if we switch to this are in @primOpInfo@, and
| CopyableOp -- marks copyable code
| NoFollowOp -- marks non-followup expression
#endif {-GRAN-}
-
-#ifdef DPH
--- Shadow all the the above primitive OPs for N dimensioned objects.
- | PodNPrimOp Int PrimOp
-
--- Primitive conversion functions.
-
- | Int2PodNOp Int | Char2PodNOp Int | Float2PodNOp Int
- | Double2PodNOp Int | String2PodNOp Int
-
-#endif {-Data Parallel Haskell -}
\end{code}
Deriving Ix is what we really want! ToDo
tagOf_PrimOp IntSubOp = ILIT( 40)
tagOf_PrimOp IntMulOp = ILIT( 41)
tagOf_PrimOp IntQuotOp = ILIT( 42)
---UNUSED:tagOf_PrimOp IntDivOp = ILIT( 43)
tagOf_PrimOp IntRemOp = ILIT( 44)
tagOf_PrimOp IntNegOp = ILIT( 45)
tagOf_PrimOp IntAbsOp = ILIT( 46)
tagOf_PrimOp DoubleEncodeOp = ILIT(115)
tagOf_PrimOp DoubleDecodeOp = ILIT(116)
tagOf_PrimOp NewArrayOp = ILIT(117)
-tagOf_PrimOp (NewByteArrayOp CharKind) = ILIT(118)
-tagOf_PrimOp (NewByteArrayOp IntKind) = ILIT(119)
-tagOf_PrimOp (NewByteArrayOp AddrKind) = ILIT(120)
-tagOf_PrimOp (NewByteArrayOp FloatKind) = ILIT(121)
-tagOf_PrimOp (NewByteArrayOp DoubleKind)= ILIT(122)
+tagOf_PrimOp (NewByteArrayOp CharRep) = ILIT(118)
+tagOf_PrimOp (NewByteArrayOp IntRep) = ILIT(119)
+tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(120)
+tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(121)
+tagOf_PrimOp (NewByteArrayOp DoubleRep)= ILIT(122)
tagOf_PrimOp SameMutableArrayOp = ILIT(123)
tagOf_PrimOp SameMutableByteArrayOp = ILIT(124)
tagOf_PrimOp ReadArrayOp = ILIT(125)
tagOf_PrimOp WriteArrayOp = ILIT(126)
tagOf_PrimOp IndexArrayOp = ILIT(127)
-tagOf_PrimOp (ReadByteArrayOp CharKind) = ILIT(128)
-tagOf_PrimOp (ReadByteArrayOp IntKind) = ILIT(129)
-tagOf_PrimOp (ReadByteArrayOp AddrKind) = ILIT(130)
-tagOf_PrimOp (ReadByteArrayOp FloatKind) = ILIT(131)
-tagOf_PrimOp (ReadByteArrayOp DoubleKind) = ILIT(132)
-tagOf_PrimOp (WriteByteArrayOp CharKind) = ILIT(133)
-tagOf_PrimOp (WriteByteArrayOp IntKind) = ILIT(134)
-tagOf_PrimOp (WriteByteArrayOp AddrKind) = ILIT(135)
-tagOf_PrimOp (WriteByteArrayOp FloatKind) = ILIT(136)
-tagOf_PrimOp (WriteByteArrayOp DoubleKind) = ILIT(137)
-tagOf_PrimOp (IndexByteArrayOp CharKind) = ILIT(138)
-tagOf_PrimOp (IndexByteArrayOp IntKind) = ILIT(139)
-tagOf_PrimOp (IndexByteArrayOp AddrKind) = ILIT(140)
-tagOf_PrimOp (IndexByteArrayOp FloatKind) = ILIT(141)
-tagOf_PrimOp (IndexByteArrayOp DoubleKind) = ILIT(142)
-tagOf_PrimOp (IndexOffAddrOp CharKind) = ILIT(143)
-tagOf_PrimOp (IndexOffAddrOp IntKind) = ILIT(144)
-tagOf_PrimOp (IndexOffAddrOp AddrKind) = ILIT(145)
-tagOf_PrimOp (IndexOffAddrOp FloatKind) = ILIT(146)
-tagOf_PrimOp (IndexOffAddrOp DoubleKind) = ILIT(147)
+tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(128)
+tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(129)
+tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(130)
+tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(131)
+tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(132)
+tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(133)
+tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(134)
+tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(135)
+tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(136)
+tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(137)
+tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(138)
+tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(139)
+tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(140)
+tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(141)
+tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(142)
+tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(143)
+tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(144)
+tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(145)
+tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(146)
+tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(147)
tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(148)
tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(149)
tagOf_PrimOp NewSynchVarOp = ILIT(150)
tagOf_PrimOp NoFollowOp = ILIT(170)
#endif {-GRAN-}
-#ifdef DPH
-tagOf_PrimOp (PodNPrimOp _ _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Int2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Char2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Float2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Double2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (String2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-#endif {-Data Parallel Haskell -}
-
--- avoid BUG
-tagOf_PrimOp _ = case (panic "tagOf_PrimOp: pattern-match") of { o ->
- tagOf_PrimOp o
- }
+tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
instance Eq PrimOp where
op == op2 = tagOf_PrimOp op _EQ_ tagOf_PrimOp op2
\end{code}
+An @Enum@-derived list would be better; meanwhile... (ToDo)
+\begin{code}
+allThePrimOps
+ = [ CharGtOp,
+ CharGeOp,
+ CharEqOp,
+ CharNeOp,
+ CharLtOp,
+ CharLeOp,
+ IntGtOp,
+ IntGeOp,
+ IntEqOp,
+ IntNeOp,
+ IntLtOp,
+ IntLeOp,
+ WordGtOp,
+ WordGeOp,
+ WordEqOp,
+ WordNeOp,
+ WordLtOp,
+ WordLeOp,
+ AddrGtOp,
+ AddrGeOp,
+ AddrEqOp,
+ AddrNeOp,
+ AddrLtOp,
+ AddrLeOp,
+ FloatGtOp,
+ FloatGeOp,
+ FloatEqOp,
+ FloatNeOp,
+ FloatLtOp,
+ FloatLeOp,
+ DoubleGtOp,
+ DoubleGeOp,
+ DoubleEqOp,
+ DoubleNeOp,
+ DoubleLtOp,
+ DoubleLeOp,
+ OrdOp,
+ ChrOp,
+ IntAddOp,
+ IntSubOp,
+ IntMulOp,
+ IntQuotOp,
+ IntRemOp,
+ IntNegOp,
+ AndOp,
+ OrOp,
+ NotOp,
+ SllOp,
+ SraOp,
+ SrlOp,
+ ISllOp,
+ ISraOp,
+ ISrlOp,
+ Int2WordOp,
+ Word2IntOp,
+ Int2AddrOp,
+ Addr2IntOp,
+ FloatAddOp,
+ FloatSubOp,
+ FloatMulOp,
+ FloatDivOp,
+ FloatNegOp,
+ Float2IntOp,
+ Int2FloatOp,
+ FloatExpOp,
+ FloatLogOp,
+ FloatSqrtOp,
+ FloatSinOp,
+ FloatCosOp,
+ FloatTanOp,
+ FloatAsinOp,
+ FloatAcosOp,
+ FloatAtanOp,
+ FloatSinhOp,
+ FloatCoshOp,
+ FloatTanhOp,
+ FloatPowerOp,
+ DoubleAddOp,
+ DoubleSubOp,
+ DoubleMulOp,
+ DoubleDivOp,
+ DoubleNegOp,
+ Double2IntOp,
+ Int2DoubleOp,
+ Double2FloatOp,
+ Float2DoubleOp,
+ DoubleExpOp,
+ DoubleLogOp,
+ DoubleSqrtOp,
+ DoubleSinOp,
+ DoubleCosOp,
+ DoubleTanOp,
+ DoubleAsinOp,
+ DoubleAcosOp,
+ DoubleAtanOp,
+ DoubleSinhOp,
+ DoubleCoshOp,
+ DoubleTanhOp,
+ DoublePowerOp,
+ IntegerAddOp,
+ IntegerSubOp,
+ IntegerMulOp,
+ IntegerQuotRemOp,
+ IntegerDivModOp,
+ IntegerNegOp,
+ IntegerCmpOp,
+ Integer2IntOp,
+ Int2IntegerOp,
+ Word2IntegerOp,
+ Addr2IntegerOp,
+ FloatEncodeOp,
+ FloatDecodeOp,
+ DoubleEncodeOp,
+ DoubleDecodeOp,
+ NewArrayOp,
+ NewByteArrayOp CharRep,
+ NewByteArrayOp IntRep,
+ NewByteArrayOp AddrRep,
+ NewByteArrayOp FloatRep,
+ NewByteArrayOp DoubleRep,
+ SameMutableArrayOp,
+ SameMutableByteArrayOp,
+ ReadArrayOp,
+ WriteArrayOp,
+ IndexArrayOp,
+ ReadByteArrayOp CharRep,
+ ReadByteArrayOp IntRep,
+ ReadByteArrayOp AddrRep,
+ ReadByteArrayOp FloatRep,
+ ReadByteArrayOp DoubleRep,
+ WriteByteArrayOp CharRep,
+ WriteByteArrayOp IntRep,
+ WriteByteArrayOp AddrRep,
+ WriteByteArrayOp FloatRep,
+ WriteByteArrayOp DoubleRep,
+ IndexByteArrayOp CharRep,
+ IndexByteArrayOp IntRep,
+ IndexByteArrayOp AddrRep,
+ IndexByteArrayOp FloatRep,
+ IndexByteArrayOp DoubleRep,
+ IndexOffAddrOp CharRep,
+ IndexOffAddrOp IntRep,
+ IndexOffAddrOp AddrRep,
+ IndexOffAddrOp FloatRep,
+ IndexOffAddrOp DoubleRep,
+ UnsafeFreezeArrayOp,
+ UnsafeFreezeByteArrayOp,
+ NewSynchVarOp,
+ ReadArrayOp,
+ TakeMVarOp,
+ PutMVarOp,
+ ReadIVarOp,
+ WriteIVarOp,
+ MakeStablePtrOp,
+ DeRefStablePtrOp,
+ ReallyUnsafePtrEqualityOp,
+ ErrorIOPrimOp,
+#ifdef GRAN
+ ParGlobalOp,
+ ParLocalOp,
+#endif {-GRAN-}
+ SeqOp,
+ ParOp,
+ ForkOp,
+ DelayOp,
+ WaitOp
+ ]
+\end{code}
+
%************************************************************************
%* *
-\subsection[PrimOps-info]{The essential info about each @PrimOp@}
+\subsection[PrimOp-info]{The essential info about each @PrimOp@}
%* *
%************************************************************************
\begin{code}
data PrimOpInfo
= Dyadic FAST_STRING -- string :: T -> T -> T
- UniType
+ Type
| Monadic FAST_STRING -- string :: T -> T
- UniType
+ Type
| Compare FAST_STRING -- string :: T -> T -> Bool
- UniType
+ Type
| Coerce FAST_STRING -- string :: T1 -> T2
- UniType
- UniType
+ Type
+ Type
| PrimResult FAST_STRING
- [TyVarTemplate] [UniType] TyCon PrimKind [UniType]
+ [TyVar] [Type] TyCon PrimRep [Type]
-- "PrimResult tvs [t1,..,tn] D# kind [s1,..,sm]"
-- has type Forall tvs. t1 -> ... -> tn -> (D# s1 ... sm)
-- D# is a primitive type constructor.
-- (the kind is the same info as D#, in another convenient form)
| AlgResult FAST_STRING
- [TyVarTemplate] [UniType] TyCon [UniType]
+ [TyVar] [Type] TyCon [Type]
-- "AlgResult tvs [t1,..,tn] T [s1,..,sm]"
-- has type Forall tvs. t1 -> ... -> tn -> (T s1 ... sm)
-- ToDo: Specialised calls to PrimOps are prohibited but may be desirable
-
-#ifdef DPH
- | PodNInfo Int
- PrimOpInfo
-#endif {- Data Parallel Haskell -}
\end{code}
Utility bits:
integerDyadic2Results name = AlgResult name [] two_Integer_tys return2GMPsTyCon []
-integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntKind []
+integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntRep []
\end{code}
@primOpInfo@ gives all essential information (from which everything
%************************************************************************
%* *
-\subsubsection[PrimOps-comparison]{PrimOpInfo basic comparison ops}
+\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}
%* *
%************************************************************************
primOpInfo CharNeOp = Compare SLIT("neChar#") charPrimTy
primOpInfo CharLtOp = Compare SLIT("ltChar#") charPrimTy
primOpInfo CharLeOp = Compare SLIT("leChar#") charPrimTy
-
+
primOpInfo IntGtOp = Compare SLIT("gtInt#") intPrimTy
primOpInfo IntGeOp = Compare SLIT("geInt#") intPrimTy
primOpInfo IntEqOp = Compare SLIT("eqInt#") intPrimTy
primOpInfo IntNeOp = Compare SLIT("neInt#") intPrimTy
primOpInfo IntLtOp = Compare SLIT("ltInt#") intPrimTy
primOpInfo IntLeOp = Compare SLIT("leInt#") intPrimTy
-
+
primOpInfo WordGtOp = Compare SLIT("gtWord#") wordPrimTy
primOpInfo WordGeOp = Compare SLIT("geWord#") wordPrimTy
primOpInfo WordEqOp = Compare SLIT("eqWord#") wordPrimTy
primOpInfo WordNeOp = Compare SLIT("neWord#") wordPrimTy
primOpInfo WordLtOp = Compare SLIT("ltWord#") wordPrimTy
primOpInfo WordLeOp = Compare SLIT("leWord#") wordPrimTy
-
+
primOpInfo AddrGtOp = Compare SLIT("gtAddr#") addrPrimTy
primOpInfo AddrGeOp = Compare SLIT("geAddr#") addrPrimTy
primOpInfo AddrEqOp = Compare SLIT("eqAddr#") addrPrimTy
primOpInfo AddrNeOp = Compare SLIT("neAddr#") addrPrimTy
primOpInfo AddrLtOp = Compare SLIT("ltAddr#") addrPrimTy
primOpInfo AddrLeOp = Compare SLIT("leAddr#") addrPrimTy
-
+
primOpInfo FloatGtOp = Compare SLIT("gtFloat#") floatPrimTy
primOpInfo FloatGeOp = Compare SLIT("geFloat#") floatPrimTy
primOpInfo FloatEqOp = Compare SLIT("eqFloat#") floatPrimTy
primOpInfo FloatNeOp = Compare SLIT("neFloat#") floatPrimTy
primOpInfo FloatLtOp = Compare SLIT("ltFloat#") floatPrimTy
primOpInfo FloatLeOp = Compare SLIT("leFloat#") floatPrimTy
-
+
primOpInfo DoubleGtOp = Compare SLIT("gtDouble#") doublePrimTy
primOpInfo DoubleGeOp = Compare SLIT("geDouble#") doublePrimTy
primOpInfo DoubleEqOp = Compare SLIT("eqDouble#") doublePrimTy
%************************************************************************
%* *
-\subsubsection[PrimOps-Char]{PrimOpInfo for @Char#@s}
+\subsubsection[PrimOp-Char]{PrimOpInfo for @Char#@s}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[PrimOps-Int]{PrimOpInfo for @Int#@s}
+\subsubsection[PrimOp-Int]{PrimOpInfo for @Int#@s}
%* *
%************************************************************************
primOpInfo IntSubOp = Dyadic SLIT("minusInt#") intPrimTy
primOpInfo IntMulOp = Dyadic SLIT("timesInt#") intPrimTy
primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy
---UNUSED:primOpInfo IntDivOp = Dyadic SLIT("divInt#") intPrimTy
primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy
primOpInfo IntNegOp = Monadic SLIT("negateInt#") intPrimTy
%************************************************************************
%* *
-\subsubsection[PrimOps-Word]{PrimOpInfo for @Word#@s}
+\subsubsection[PrimOp-Word]{PrimOpInfo for @Word#@s}
%* *
%************************************************************************
primOpInfo NotOp = Monadic SLIT("not#") wordPrimTy
primOpInfo SllOp
- = PrimResult SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
+ = PrimResult SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
primOpInfo SraOp
- = PrimResult SLIT("shiftRA#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
+ = PrimResult SLIT("shiftRA#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
primOpInfo SrlOp
- = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
+ = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
primOpInfo ISllOp
- = PrimResult SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
+ = PrimResult SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
primOpInfo ISraOp
- = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
+ = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
primOpInfo ISrlOp
- = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
+ = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
primOpInfo Int2WordOp = Coerce SLIT("int2Word#") intPrimTy wordPrimTy
primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy
%************************************************************************
%* *
-\subsubsection[PrimOps-Addr]{PrimOpInfo for @Addr#@s}
+\subsubsection[PrimOp-Addr]{PrimOpInfo for @Addr#@s}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[PrimOps-Float]{PrimOpInfo for @Float#@s}
+\subsubsection[PrimOp-Float]{PrimOpInfo for @Float#@s}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[PrimOps-Double]{PrimOpInfo for @Double#@s}
+\subsubsection[PrimOp-Double]{PrimOpInfo for @Double#@s}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[PrimOps-Integer]{PrimOpInfo for @Integer@ (and related!)}
+\subsubsection[PrimOp-Integer]{PrimOpInfo for @Integer@ (and related!)}
%* *
%************************************************************************
primOpInfo IntegerDivModOp = integerDyadic2Results SLIT("divModInteger#")
primOpInfo Integer2IntOp
- = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntKind []
+ = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntRep []
primOpInfo Int2IntegerOp
= AlgResult SLIT("int2Integer#") [] [intPrimTy] integerTyCon []
\begin{code}
primOpInfo FloatEncodeOp
= PrimResult SLIT("encodeFloat#") [] an_Integer_and_Int_tys
- floatPrimTyCon FloatKind []
+ floatPrimTyCon FloatRep []
primOpInfo DoubleEncodeOp
= PrimResult SLIT("encodeDouble#") [] an_Integer_and_Int_tys
- doublePrimTyCon DoubleKind []
+ doublePrimTyCon DoubleRep []
primOpInfo FloatDecodeOp
= AlgResult SLIT("decodeFloat#") [] [floatPrimTy] returnIntAndGMPTyCon []
%************************************************************************
%* *
-\subsubsection[PrimOps-Arrays]{PrimOpInfo for primitive arrays}
+\subsubsection[PrimOp-Arrays]{PrimOpInfo for primitive arrays}
%* *
%************************************************************************
\begin{code}
primOpInfo NewArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("newArray#") [s_tv, elt_tv] [intPrimTy, elt, mkStatePrimTy s]
stateAndMutableArrayPrimTyCon [s, elt]
primOpInfo (NewByteArrayOp kind)
= let
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
- (str, _, prim_tycon) = getKindInfo kind
+ (str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("new" ++ str ++ "Array#")
in
- AlgResult op_str [s_tv]
- [intPrimTy, mkStatePrimTy s]
+ AlgResult op_str [s_tv]
+ [intPrimTy, mkStatePrimTy s]
stateAndMutableByteArrayPrimTyCon [s]
---------------------------------------------------------------------------
primOpInfo SameMutableArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv;
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
mut_arr_ty = mkMutableArrayPrimTy s elt
} in
AlgResult SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
primOpInfo SameMutableByteArrayOp
= let {
- s = alpha; s_tv = alpha_tv;
+ s = alphaTy; s_tv = alphaTyVar;
mut_arr_ty = mkMutableByteArrayPrimTy s
} in
AlgResult SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
primOpInfo ReadArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("readArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, intPrimTy, mkStatePrimTy s]
primOpInfo WriteArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
PrimResult SLIT("writeArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s]
- statePrimTyCon VoidKind [s]
+ statePrimTyCon VoidRep [s]
primOpInfo IndexArrayOp
- = let { elt = alpha; elt_tv = alpha_tv } in
+ = let { elt = alphaTy; elt_tv = alphaTyVar } in
AlgResult SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
liftTyCon [elt]
primOpInfo (ReadByteArrayOp kind)
= let
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
- (str, _, prim_tycon) = getKindInfo kind
+ (str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("read" ++ str ++ "Array#")
relevant_tycon = assoc "primOpInfo" tbl kind
[mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s]
relevant_tycon [s]
where
- tbl = [ (CharKind, stateAndCharPrimTyCon),
- (IntKind, stateAndIntPrimTyCon),
- (AddrKind, stateAndAddrPrimTyCon),
- (FloatKind, stateAndFloatPrimTyCon),
- (DoubleKind, stateAndDoublePrimTyCon) ]
+ tbl = [ (CharRep, stateAndCharPrimTyCon),
+ (IntRep, stateAndIntPrimTyCon),
+ (AddrRep, stateAndAddrPrimTyCon),
+ (FloatRep, stateAndFloatPrimTyCon),
+ (DoubleRep, stateAndDoublePrimTyCon) ]
-- How come there's no Word byte arrays? ADR
primOpInfo (WriteByteArrayOp kind)
= let
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
- (str, prim_ty, _) = getKindInfo kind
+ (str, prim_ty, _) = getPrimRepInfo kind
op_str = _PK_ ("write" ++ str ++ "Array#")
in
-- NB: *Prim*Result --
PrimResult op_str [s_tv]
[mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]
- statePrimTyCon VoidKind [s]
+ statePrimTyCon VoidRep [s]
primOpInfo (IndexByteArrayOp kind)
= let
- (str, _, prim_tycon) = getKindInfo kind
+ (str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "Array#")
in
-- NB: *Prim*Result --
primOpInfo (IndexOffAddrOp kind)
= let
- (str, _, prim_tycon) = getKindInfo kind
+ (str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "OffAddr#")
in
PrimResult op_str [] [addrPrimTy, intPrimTy] prim_tycon kind []
---------------------------------------------------------------------------
primOpInfo UnsafeFreezeArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, mkStatePrimTy s]
stateAndArrayPrimTyCon [s, elt]
primOpInfo UnsafeFreezeByteArrayOp
- = let { s = alpha; s_tv = alpha_tv } in
+ = let { s = alphaTy; s_tv = alphaTyVar } in
AlgResult SLIT("unsafeFreezeByteArray#") [s_tv]
[mkMutableByteArrayPrimTy s, mkStatePrimTy s]
stateAndByteArrayPrimTyCon [s]
%************************************************************************
%* *
-\subsubsection[PrimOps-SynchVars]{PrimOpInfo for synchronizing Variables}
+\subsubsection[PrimOp-SynchVars]{PrimOpInfo for synchronizing Variables}
%* *
%************************************************************************
\begin{code}
primOpInfo NewSynchVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("newSynchVar#") [s_tv, elt_tv] [mkStatePrimTy s]
stateAndSynchVarPrimTyCon [s, elt]
primOpInfo TakeMVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("takeMVar#") [s_tv, elt_tv]
[mkSynchVarPrimTy s elt, mkStatePrimTy s]
primOpInfo PutMVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("putMVar#") [s_tv, elt_tv]
[mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
primOpInfo ReadIVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("readIVar#") [s_tv, elt_tv]
[mkSynchVarPrimTy s elt, mkStatePrimTy s]
primOpInfo WriteIVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("writeIVar#") [s_tv, elt_tv]
[mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
%************************************************************************
%* *
-\subsubsection[PrimOps-Wait]{PrimOpInfo for delay/wait operations}
+\subsubsection[PrimOp-Wait]{PrimOpInfo for delay/wait operations}
%* *
%************************************************************************
primOpInfo DelayOp
= let {
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
} in
PrimResult SLIT("delay#") [s_tv]
[intPrimTy, mkStatePrimTy s]
- statePrimTyCon VoidKind [s]
+ statePrimTyCon VoidRep [s]
primOpInfo WaitOp
= let {
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
} in
PrimResult SLIT("wait#") [s_tv]
[intPrimTy, mkStatePrimTy s]
- statePrimTyCon VoidKind [s]
+ statePrimTyCon VoidRep [s]
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-stable-pointers]{PrimOpInfo for ``stable pointers''}
+\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for ``stable pointers''}
%* *
%************************************************************************
\begin{code}
primOpInfo MakeStablePtrOp
- = AlgResult SLIT("makeStablePtr#") [alpha_tv]
- [alpha, realWorldStatePrimTy]
- stateAndStablePtrPrimTyCon [realWorldTy, alpha]
+ = AlgResult SLIT("makeStablePtr#") [alphaTyVar]
+ [alphaTy, realWorldStatePrimTy]
+ stateAndStablePtrPrimTyCon [realWorldTy, alphaTy]
primOpInfo DeRefStablePtrOp
- = AlgResult SLIT("deRefStablePtr#") [alpha_tv]
- [mkStablePtrPrimTy alpha, realWorldStatePrimTy]
- stateAndPtrPrimTyCon [realWorldTy, alpha]
+ = AlgResult SLIT("deRefStablePtr#") [alphaTyVar]
+ [mkStablePtrPrimTy alphaTy, realWorldStatePrimTy]
+ stateAndPtrPrimTyCon [realWorldTy, alphaTy]
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-unsafePointerEquality]{PrimOpInfo for Pointer Equality}
+\subsubsection[PrimOp-unsafePointerEquality]{PrimOpInfo for Pointer Equality}
%* *
%************************************************************************
\begin{code}
primOpInfo ReallyUnsafePtrEqualityOp
- = PrimResult SLIT("reallyUnsafePtrEquality#") [alpha_tv]
- [alpha, alpha] intPrimTyCon IntKind []
+ = PrimResult SLIT("reallyUnsafePtrEquality#") [alphaTyVar]
+ [alphaTy, alphaTy] intPrimTyCon IntRep []
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-parallel]{PrimOpInfo for parallelism op(s)}
+\subsubsection[PrimOp-parallel]{PrimOpInfo for parallelism op(s)}
%* *
%************************************************************************
\begin{code}
primOpInfo SeqOp -- seq# :: a -> Int#
- = PrimResult SLIT("seq#") [alpha_tv] [alpha] intPrimTyCon IntKind []
+ = PrimResult SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep []
primOpInfo ParOp -- par# :: a -> Int#
- = PrimResult SLIT("par#") [alpha_tv] [alpha] intPrimTyCon IntKind []
+ = PrimResult SLIT("par#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep []
primOpInfo ForkOp -- fork# :: a -> Int#
- = PrimResult SLIT("fork#") [alpha_tv] [alpha] intPrimTyCon IntKind []
+ = PrimResult SLIT("fork#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep []
\end{code}
#ifdef GRAN
primOpInfo ParGlobalOp -- parGlobal# :: Int -> a -> b -> b
- = AlgResult SLIT("parGlobal#") [alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta]
+ = AlgResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
primOpInfo ParLocalOp -- parLocal# :: Int -> a -> b -> b
- = AlgResult SLIT("parLocal#") [alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta]
+ = AlgResult SLIT("parLocal#") [alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
primOpInfo ParAtOp -- parAt# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAt#") [alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma]
+ = AlgResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
primOpInfo ParAtForNowOp -- parAtForNow# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAtForNow#") [alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma]
+ = AlgResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
primOpInfo CopyableOp -- copyable# :: a -> a
- = AlgResult SLIT("copyable#") [alpha_tv] [alpha] liftTyCon [alpha]
+ = AlgResult SLIT("copyable#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
primOpInfo NoFollowOp -- noFollow# :: a -> a
- = AlgResult SLIT("noFollow#") [alpha_tv] [alpha] liftTyCon [alpha]
+ = AlgResult SLIT("noFollow#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
#endif {-GRAN-}
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-errorIO]{PrimOpInfo for @errorIO#@}
+\subsubsection[PrimOp-errorIO]{PrimOpInfo for @errorIO#@}
%* *
%************************************************************************
primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
= PrimResult SLIT("errorIO#") []
[mkPrimIoTy unitTy]
- statePrimTyCon VoidKind [realWorldTy]
+ statePrimTyCon VoidRep [realWorldTy]
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-IO-etc]{PrimOpInfo for C calls, and I/O-ish things}
+\subsubsection[PrimOp-IO-etc]{PrimOpInfo for C calls, and I/O-ish things}
%* *
%************************************************************************
primOpInfo (CCallOp _ _ _ arg_tys result_ty)
= AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
where
- (result_tycon, tys_applied, _) = getUniDataTyCon result_ty
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOps-DPH]{PrimOpInfo for Data Parallel Haskell}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef DPH
--- ToDo:DPH: various things need doing here
-
-primOpInfo (Int2PodNOp d) = Coerce ("int2Pod" ++ show d)
- IntKind
- (PodNKind d IntKind)
-
-primOpInfo (Char2PodNOp d) = Coerce ("char2Pod" ++ show d)
- CharKind
- (PodNKind d CharKind)
-
-primOpInfo (Float2PodNOp d) = Coerce ("float2Pod" ++ show d)
- FloatKind
- (PodNKind d FloatKind)
-
-primOpInfo (Double2PodNOp d) = Coerce ("double2Pod" ++ show d)
- DoubleKind
- (PodNKind d DoubleKind)
-
-{-
-primOpInfo (Integer2PodNOp d) = Coerce ("integer2Pod" ++ show d)
- IntegerKind
- (PodNKind d IntegerKind)
--}
-
-primOpInfo (String2PodNOp d) = Coerce ("string2Pod" ++ show d)
- LitStringKind
- (PodNKind d LitStringKind)
-
-primOpInfo (PodNPrimOp d p) = PodNInfo d (primOpInfo p)
-#endif {- Data Parallel Haskell -}
+ (result_tycon, tys_applied, _) = getAppDataTyCon result_ty
\end{code}
%************************************************************************
%* *
-\subsection[PrimOps-utils]{Utilities for @PrimitiveOps@}
+\subsection[PrimOp-utils]{Utilities for @PrimitiveOps@}
%* *
%************************************************************************
a fixed amount of heap is required, and the needs of the @PrimOp@ can
be combined with the rest of the heap usage in the basic block. For an
unfortunate few, some unknown amount of heap is required (these are the
-ops which can trigger GC).
+ops which can trigger GC).
\begin{code}
-data HeapRequirement
- = NoHeapRequired
- | FixedHeapRequired HeapOffset
+{- MOVE:
+data HeapRequirement
+ = NoHeapRequired
+ | FixedHeapRequired HeapOffset
| VariableHeapRequired
primOpHeapReq :: PrimOp -> HeapRequirement
primOpHeapReq IntegerQuotRemOp = VariableHeapRequired
primOpHeapReq IntegerDivModOp = VariableHeapRequired
primOpHeapReq IntegerNegOp = VariableHeapRequired
-primOpHeapReq Int2IntegerOp = FixedHeapRequired
+primOpHeapReq Int2IntegerOp = FixedHeapRequired
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE))
-primOpHeapReq Word2IntegerOp = FixedHeapRequired
+primOpHeapReq Word2IntegerOp = FixedHeapRequired
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE))
primOpHeapReq Addr2IntegerOp = VariableHeapRequired
-primOpHeapReq FloatDecodeOp = FixedHeapRequired
- (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE))
+primOpHeapReq FloatDecodeOp = FixedHeapRequired
+ (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE))
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE)))
-primOpHeapReq DoubleDecodeOp = FixedHeapRequired
- (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE))
+primOpHeapReq DoubleDecodeOp = FixedHeapRequired
+ (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE))
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE)))
else NoHeapRequired
where
returnsMallocPtr
- = case (getUniDataTyCon_maybe return_ty) of
+ = case (maybeAppDataTyCon return_ty) of
Nothing -> False
Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon
primOpHeapReq DoubleEncodeOp = FixedHeapRequired (intOff mP_STRUCT_SIZE)
-- a NewSynchVarOp creates a three-word mutuple in the heap.
-primOpHeapReq NewSynchVarOp = FixedHeapRequired
+primOpHeapReq NewSynchVarOp = FixedHeapRequired
(addOff (totHdrSize (MuTupleRep 3)) (intOff 3))
-- Sparking ops no longer allocate any heap; however, _fork_ may
#endif {-GRAN-}
primOpHeapReq other_op = NoHeapRequired
+-}
\end{code}
Primops which can trigger GC have to be called carefully.
-In particular, their arguments are guaranteed to be in registers,
+In particular, their arguments are guaranteed to be in registers,
and a liveness mask tells which regs are live.
\begin{code}
-primOpCanTriggerGC op =
+{- MOVE:
+primOpCanTriggerGC op =
case op of
TakeMVarOp -> True
ReadIVarOp -> True
DelayOp -> True
WaitOp -> True
- _ ->
- case primOpHeapReq op of
+ _ ->
+ case primOpHeapReq op of
VariableHeapRequired -> True
_ -> False
-
+-}
\end{code}
Sometimes we may choose to execute a PrimOp even though it isn't
of by data dependencies.
\begin{code}
+{- MOVE:
primOpOkForSpeculation :: PrimOp -> Bool
-- Int.
---UNUSED:primOpOkForSpeculation IntDivOp = False -- Divide by zero
primOpOkForSpeculation IntQuotOp = False -- Divide by zero
primOpOkForSpeculation IntRemOp = False -- Divide by zero
-- The default is "yes it's ok for speculation"
primOpOkForSpeculation other_op = True
+-}
\end{code}
@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK
WARNING), we just borrow some other predicates for a
what-should-be-good-enough test.
\begin{code}
+{-MOVE:
primOpIsCheap op
= primOpOkForSpeculation op && not (primOpCanTriggerGC op)
+-}
\end{code}
And some primops have side-effects and so, for example, must not be
duplicated.
\begin{code}
+{- MOVE:
fragilePrimOp :: PrimOp -> Bool
fragilePrimOp ParOp = True
#endif {-GRAN-}
fragilePrimOp other = False
+-}
\end{code}
Primitive operations that perform calls need wrappers to save any live variables
that are stored in caller-saves registers
\begin{code}
+{- MOVE:
primOpNeedsWrapper :: PrimOp -> Bool
primOpNeedsWrapper (CCallOp _ _ _ _ _) = True
---UNUSED:primOpNeedsWrapper IntDivOp = True
-
primOpNeedsWrapper NewArrayOp = True -- ToDo: for nativeGen only!(JSM)
primOpNeedsWrapper (NewByteArrayOp _) = True
primOpNeedsWrapper WaitOp = True
primOpNeedsWrapper other_op = False
+-}
\end{code}
\begin{code}
-primOpId :: PrimOp -> Id
-primOpNameInfo :: PrimOp -> (FAST_STRING, Name)
-
--- the *NameInfo ones are trivial:
-
-primOpNameInfo op = (primOp_str op, WiredInVal (primOpId op))
-
primOp_str op
= case (primOpInfo op) of
Dyadic str _ -> str
Monadic str _ -> str
Compare str _ -> str
- Coerce str _ _ -> str
+ Coerce str _ _ -> str
PrimResult str _ _ _ _ _ -> str
AlgResult str _ _ _ _ -> str
-#ifdef DPH
- PodNInfo d i -> case i of
- Dyadic str _ -> (str ++ ".POD" ++ show d ++ "#")
- Monadic str _ -> (str ++ ".POD" ++ show d ++ "#")
- Compare str _ -> (str ++ ".POD" ++ show d ++ "#")
- Coerce str _ _ -> (str ++ ".POD" ++ show d ++ "#")
- PrimResult str _ _ _ _ _ -> (str ++ ".POD" ++ show d)
- AlgResult str _ _ _ _ -> (str ++ ".POD" ++ show d)
-#endif {- Data Parallel Haskell -}
\end{code}
-@typeOfPrimOp@ duplicates some work of @primOpId@, but since we
+@primOpType@ duplicates some work of @primOpId@, but since we
grab types pretty often...
\begin{code}
-typeOfPrimOp :: PrimOp -> UniType
+primOpType :: PrimOp -> Type
-#ifdef DPH
-typeOfPrimOp (PodNPrimOp d p)
- = mkPodizedPodNTy d (typeOfPrimOp p)
-#endif {- Data Parallel Haskell -}
-
-typeOfPrimOp op
+primOpType op
= case (primOpInfo op) of
Dyadic str ty -> dyadic_fun_ty ty
Monadic str ty -> monadic_fun_ty ty
- Compare str ty -> prim_compare_fun_ty ty
- Coerce str ty1 ty2 -> UniFun ty1 ty2
-
- PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
- mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys))
-
- AlgResult str tyvars arg_tys tycon res_tys ->
- mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys))
-\end{code}
-
-\begin{code}
-primOpId op
- = case (primOpInfo op) of
- Dyadic str ty ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
-
- Monadic str ty ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
-
- Compare str ty ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (prim_compare_fun_ty ty) 2
-
- Coerce str ty1 ty2 ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (UniFun ty1 ty2) 1
+ Compare str ty -> compare_fun_ty ty
+ Coerce str ty1 ty2 -> mkFunTys [ty1] ty2
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
- mk_prim_Id op pRELUDE_BUILTIN str
- tyvars
- arg_tys
- (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys)))
- (length arg_tys) -- arity
+ mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys))
AlgResult str tyvars arg_tys tycon res_tys ->
- mk_prim_Id op pRELUDE_BUILTIN str
- tyvars
- arg_tys
- (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys)))
- (length arg_tys) -- arity
-
-#ifdef DPH
- PodNInfo d i -> panic "primOpId : Oi lazy, PodNInfo needs sorting out"
-#endif {- Data Parallel Haskell -}
- where
- mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
- = mkPreludeId
- (mkPrimOpIdUnique prim_op)
- (mkPreludeCoreName mod name)
- ty
- (noIdInfo
- `addInfo` (mkArityInfo arity)
- `addInfo_UF` (mkUnfolding EssentialUnfolding
- (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
-\end{code}
-
-The functions to make common unfoldings are tedious.
-
-\begin{code}
-mk_prim_unfold :: PrimOp -> [TyVarTemplate] -> [UniType] -> PlainCoreExpr{-template-}
-
-mk_prim_unfold prim_op tv_tmpls arg_tys
- = let
- (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls (map getTheUnique tv_tmpls)
- inst_arg_tys = map (instantiateTauTy inst_env) arg_tys
- vars = mkTemplateLocals inst_arg_tys
- in
- foldr CoTyLam (mkCoLam vars
- (CoPrim prim_op tyvar_tys [CoVarAtom v | v <- vars]))
- tyvars
+ mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys))
\end{code}
\begin{code}
data PrimOpResultInfo
- = ReturnsPrim PrimKind
+ = ReturnsPrim PrimRep
| ReturnsAlg TyCon
-- ToDo: Deal with specialised PrimOps
getPrimOpResultInfo op
= case (primOpInfo op) of
- Dyadic _ ty -> ReturnsPrim (kindFromType ty)
- Monadic _ ty -> ReturnsPrim (kindFromType ty)
+ Dyadic _ ty -> ReturnsPrim (primRepFromType ty)
+ Monadic _ ty -> ReturnsPrim (primRepFromType ty)
Compare _ ty -> ReturnsAlg boolTyCon
- Coerce _ _ ty -> ReturnsPrim (kindFromType ty)
+ Coerce _ _ ty -> ReturnsPrim (primRepFromType ty)
PrimResult _ _ _ _ kind _ -> ReturnsPrim kind
AlgResult _ _ _ tycon _ -> ReturnsAlg tycon
-#ifdef DPH
- PodNInfo d i -> panic "getPrimOpResultInfo:PodNInfo"
-#endif {- Data Parallel Haskell -}
isCompareOp :: PrimOp -> Bool
Utils:
\begin{code}
-dyadic_fun_ty ty = ty `UniFun` (ty `UniFun` ty)
-monadic_fun_ty ty = ty `UniFun` ty
-
-compare_fun_ty ty = ty `UniFun` (ty `UniFun` boolTy)
-prim_compare_fun_ty ty = ty `UniFun` (ty `UniFun` boolTy)
+dyadic_fun_ty ty = mkFunTys [ty, ty] ty
+monadic_fun_ty ty = mkFunTys [ty] ty
+compare_fun_ty ty = mkFunTys [ty, ty] boolTy
\end{code}
Output stuff:
pp_tys
= ppBesides [ppStr " { [",
- ppIntersperse pp'SP{-'-} (map (pprParendUniType sty) arg_tys),
- ppRbrack, ppSP, pprParendUniType sty res_ty, ppStr " })"]
+ ppIntersperse pp'SP{-'-} (map (pprParendType sty) arg_tys),
+ ppRbrack, ppSP, pprParendType sty res_ty, ppStr " })"]
in
ppBesides [ppStr before, ppPStr fun, after, pp_tys]
-#ifdef DPH
- = fun -- Comment buggers up machine code :-) -- ToDo:DPH
-#endif {- Data Parallel Haskell -}
pprPrimOp sty other_op
= let
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrimOps where
-import Class(Class)
-import HeapOffs(HeapOffset)
-import Id(Id)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import PrimKind(PrimKind)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique)
-data HeapOffset
-data HeapRequirement = NoHeapRequired | FixedHeapRequired HeapOffset | VariableHeapRequired
-data Id
-data Name
-data PrimKind
-data PrimOp
- = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp
-data PrimOpInfo = Dyadic _PackedString UniType | Monadic _PackedString UniType | Compare _PackedString UniType | Coerce _PackedString UniType UniType | PrimResult _PackedString [TyVarTemplate] [UniType] TyCon PrimKind [UniType] | AlgResult _PackedString [TyVarTemplate] [UniType] TyCon [UniType]
-data PrimOpResultInfo = ReturnsPrim PrimKind | ReturnsAlg TyCon
-data TyCon
-data TyVarTemplate
-data UniType
-fragilePrimOp :: PrimOp -> Bool
-getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
-isCompareOp :: PrimOp -> Bool
-pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep
-primOpCanTriggerGC :: PrimOp -> Bool
-primOpHeapReq :: PrimOp -> HeapRequirement
-primOpId :: PrimOp -> Id
-primOpIsCheap :: PrimOp -> Bool
-primOpNameInfo :: PrimOp -> (_PackedString, Name)
-primOpNeedsWrapper :: PrimOp -> Bool
-primOpOkForSpeculation :: PrimOp -> Bool
-showPrimOp :: PprStyle -> PrimOp -> [Char]
-tagOf_PrimOp :: PrimOp -> Int#
-typeOfPrimOp :: PrimOp -> UniType
-instance Eq PrimOp
-instance Outputable PrimOp
-
--- /dev/null
+%
+% (c) The GRASP Project, Glasgow University, 1992-1996
+%
+\section[PrimRep]{Primitive machine-level kinds of things.}
+
+At various places in the back end, we want to be to tag things with a
+``primitive kind''---i.e., the machine-manipulable implementation
+types.
+
+\begin{code}
+#include "HsVersions.h"
+
+module PrimRep (
+ PrimRep(..),
+
+ separateByPtrFollowness, isFollowableRep, isFloatingRep,
+ getPrimRepSize, retPrimRepSize,
+ showPrimRep,
+ guessPrimRep
+ ) where
+
+import Ubiq
+
+import Pretty -- pretty-printing code
+import Util
+
+#include "../../includes/GhcConstants.h"
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[PrimRep-datatype]{The @PrimRep@ datatype}
+%* *
+%************************************************************************
+
+\begin{code}
+data PrimRep
+ = -- These pointer-kinds are all really the same, but we keep
+ -- them separate for documentation purposes.
+ PtrRep -- Pointer to a closure; a ``word''.
+ | CodePtrRep -- Pointer to code
+ | DataPtrRep -- Pointer to data
+ | RetRep -- Pointer to code or data (return vector or code pointer)
+ | CostCentreRep -- Pointer to a cost centre
+
+ | CharRep -- Machine characters
+ | IntRep -- integers (at least 32 bits)
+ | WordRep -- ditto (but *unsigned*)
+ | AddrRep -- addresses ("C pointers")
+ | FloatRep -- floats
+ | DoubleRep -- doubles
+
+ | MallocPtrRep -- This has to be a special kind because ccall
+ -- generates special code when passing/returning
+ -- one of these. [ADR]
+
+ | StablePtrRep -- We could replace this with IntRep but maybe
+ -- there's some documentation gain from having
+ -- it special? [ADR]
+
+ | ArrayRep -- Primitive array of Haskell pointers
+ | ByteArrayRep -- Primitive array of bytes (no Haskell pointers)
+
+ | VoidRep -- Occupies no space at all!
+ -- (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}
+
+%************************************************************************
+%* *
+\subsection[PrimRep-predicates]{Follow-ness, sizes, and such---on @PrimitiveKinds@}
+%* *
+%************************************************************************
+
+Whether or not the thing is a pointer that the garbage-collector
+should follow.
+
+Or, to put it another (less confusing) way, whether the object in
+question is a heap object.
+
+\begin{code}
+isFollowableRep :: PrimRep -> Bool
+
+isFollowableRep PtrRep = True
+isFollowableRep ArrayRep = True
+isFollowableRep ByteArrayRep = True
+isFollowableRep MallocPtrRep = True
+
+isFollowableRep StablePtrRep = False
+-- StablePtrs aren't followable because they are just indices into a
+-- table for which explicit allocation/ deallocation is required.
+
+isFollowableRep other = False
+
+separateByPtrFollowness :: (a -> PrimRep) -> [a] -> ([a], [a])
+
+separateByPtrFollowness kind_fun things
+ = sep_things kind_fun things [] []
+ -- accumulating params for follow-able and don't-follow things...
+ where
+ sep_things kfun [] bs us = (reverse bs, reverse us)
+ sep_things kfun (t:ts) bs us
+ = if (isFollowableRep . kfun) t then
+ sep_things kfun ts (t:bs) us
+ else
+ sep_things kfun ts bs (t:us)
+\end{code}
+
+@isFloatingRep@ is used to distinguish @Double@ and @Float@ which
+cause inadvertent numeric conversions if you aren't jolly careful.
+See codeGen/CgCon:cgTopRhsCon.
+
+\begin{code}
+isFloatingRep :: PrimRep -> Bool
+
+isFloatingRep DoubleRep = True
+isFloatingRep FloatRep = True
+isFloatingRep other = False
+\end{code}
+
+\begin{code}
+getPrimRepSize :: PrimRep -> Int
+
+getPrimRepSize DoubleRep = DOUBLE_SIZE -- "words", of course
+--getPrimRepSize FloatRep = 1
+--getPrimRepSize CharRep = 1 -- ToDo: count in bytes?
+--getPrimRepSize ArrayRep = 1 -- Listed specifically for *documentation*
+--getPrimRepSize ByteArrayRep = 1
+getPrimRepSize VoidRep = 0
+getPrimRepSize other = 1
+
+retPrimRepSize = getPrimRepSize RetRep
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[PrimRep-instances]{Boring instance decls for @PrimRep@}
+%* *
+%************************************************************************
+
+\begin{code}
+instance Outputable PrimRep where
+ ppr sty kind = ppStr (showPrimRep kind)
+
+showPrimRep :: PrimRep -> String
+guessPrimRep :: String -> PrimRep -- a horrible "inverse" function
+
+showPrimRep PtrRep = "P_" -- short for StgPtr
+
+showPrimRep CodePtrRep = "P_" -- DEATH to StgFunPtr! (94/02/22 WDP)
+ -- but aren't code pointers and function pointers different sizes
+ -- on some machines (eg 80x86)? ADR
+ -- Are you trying to ruin my life, or what? (WDP)
+
+showPrimRep DataPtrRep = "D_"
+showPrimRep RetRep = "StgRetAddr"
+showPrimRep CostCentreRep = "CostCentre"
+showPrimRep CharRep = "StgChar"
+showPrimRep IntRep = "I_" -- short for StgInt
+showPrimRep WordRep = "W_" -- short for StgWord
+showPrimRep AddrRep = "StgAddr"
+showPrimRep FloatRep = "StgFloat"
+showPrimRep DoubleRep = "StgDouble"
+showPrimRep ArrayRep = "StgArray" -- see comment below
+showPrimRep ByteArrayRep = "StgByteArray"
+showPrimRep StablePtrRep = "StgStablePtr"
+showPrimRep MallocPtrRep = "StgPtr" -- see comment below
+showPrimRep VoidRep = "!!VOID_KIND!!"
+
+guessPrimRep "D_" = DataPtrRep
+guessPrimRep "StgRetAddr" = RetRep
+guessPrimRep "StgChar" = CharRep
+guessPrimRep "I_" = IntRep
+guessPrimRep "W_" = WordRep
+guessPrimRep "StgAddr" = AddrRep
+guessPrimRep "StgFloat" = FloatRep
+guessPrimRep "StgDouble" = DoubleRep
+guessPrimRep "StgArray" = ArrayRep
+guessPrimRep "StgByteArray" = ByteArrayRep
+guessPrimRep "StgStablePtr" = StablePtrRep
+\end{code}
+
+All local C variables of @ArrayRep@ are declared in C as type
+@StgArray@. The coercion to a more precise C type is done just before
+indexing (by the relevant C primitive-op macro).
+
+Nota Bene. There are three types associated with Malloc Pointers:
+\begin{itemize}
+\item
+@StgMallocClosure@ is the type of the thing the C world gives us.
+(This typename is hardwired into @ppr_casm_results@ in
+@PprAbsC.lhs@.)
+
+\item
+@StgMallocPtr@ is the type of the thing we give the C world.
+
+\item
+@StgPtr@ is the type of the (pointer to the) heap object which we
+pass around inside the STG machine.
+\end{itemize}
+
+It is really easy to confuse the two. (I'm not sure this choice of
+type names helps.) [ADR]
+++ /dev/null
-%************************************************************************
-%* *
-\section[TyPod]{The Pod datatype}
-%* *
-%************************************************************************
-\begin{code}
-#include "HsVersions.h"
-
-module TyPod where
-
-import PrelFuns -- help functions, types and things
-import TyInteger --ToDo:DPH: no such thing any more!
-import TyProcs
-import TyBool ( boolTy )
-import Unique
-
-import AbsUniType ( getUniDataTyCon_maybe , mkPodizedPodTyCon )
-import Maybes
-\end{code}
-
-In the implementation of \DPHaskell{} for a SIMD machine, we adopt three
-diffrent models of \POD{}s.
-
-%************************************************************************
-\subsection[User]{The Users model}
-%************************************************************************
-The users model of a \POD{} is outlined in ``Data Parallel Haskell: Mixing old
-and new glue''\cite{hill:dpglue}. In this model, a \POD{} represents a
-collection of index value pairs, where each index uniquely identifies a
-single element of a \POD{}. As \POD{}s are an abstraction of the processing
-elements of a data parallel machine, we choose to collect the index value
-pairs into a data type we call a `processor'.
-
-The indices of a \POD{} can be thought of as a subset of the
-integers\footnote{10/03/93: I've decided to change the index types of \POD{}'s
----they are now Int's {\em not} Integer's. The use of the GMP package has
-changed things, Integers are now special, and there's no way I'm going
-to have time to implement them on the DAP. I would like Integers to be like
-Ints, i.e a single boxed primitive value --- they are'nt like that any more.
-I've therefore plumped for Int's as index values, which means indices
-are restricted to 32bit signed values.}. We use
-the Haskell class system to extend the range of possible types for the indices
-such that any type that is an instance of the class {\tt Pid} (processor
-identifier) may be used as an index type.
-
-%************************************************************************
-\subsection[prePodized]{The Core Syntax model before podization}
-%************************************************************************
-Desugaring of the abstract syntax introduces the overloaded operators
-{\tt fromDomain} and {\tt toDomain} to convert the index types to integers.
-We bring the \POD{} type and processor types closer together in the core
-syntax; \POD{}s will have types such as {\tt <<Int,Int;Char>>} in
-which the integer types before the ``;'' determine the position of an
-element identified by those integers within a two dimensioned \POD{}
-(i.e a matrix).
-%************************************************************************
-\subsection[postPodized]{The Core Syntax model after podization}
-%************************************************************************
-Things drastically change after podization. There are four different
-variety of \POD{}s being used at runtime:
-\begin{enumerate}
-\item[Interface] A $k$ dimensional Interface \POD{} of $\alpha$'s is
- represented by a product type that contains a $k$ dimensional
- inside out \POD{} of Boolean values that determine at what
- processors the Interface \POD{} is to be defined; and a $k$
- dimensional inside out \POD{} of $\alpha$'s - the \POD{}s that
- the user manipulates in \POD{} comprehensions are all
- interface \POD{}'s --- see note **1** on efficiency below.
-
-\item[Podized] The remaining types of \POD{}s are invisible to the user
- - See the podization files for more details (even a bit
- sketchy their :-(
-
-\item[Primitive] A $k$ dimensional unboxed \POD{} is a contiguous subset of
- primitive unboxed values - these will hopefully be the
- staple diet of Data Parallel evaluation. For non SIMD
- people, these are just like `C' arrays, except we can apply
- primitive parallel operations to them---for example add
- two arrays together.
-
-\item[Hard luck] Hard luck \POD{}s are the ones that we cann't implement in a
- parallel manner - see podization files for more details.
-\end{enumerate}
-
-Note **1** : Efficiency of parallel functions.
-
-There are various (trivial) laws concerning \POD{} comprehensions, such as
-
-(vectorMap f) . (vectorMap g) == vectorMap (f.g)
-
-The right of the above expressions is more ``efficient'' because we only
-unbox the interface \POD{}, then check for undefined elements once in contrast
-to twice in the left expression. Maybe theres some scope here for some
-simplifications ??
-
-%************************************************************************
-%* *
-\section[User_POD]{The ``Users model'' of a Pod}
-%* *
-%************************************************************************
-\begin{code}
-mkPodTy :: UniType -> UniType
-mkPodTy ty = UniData podTyCon [ty]
-
-mkPodNTy:: Int -> UniType -> UniType
-mkPodNTy n ty = UniData podTyCon [mkProcessorTy (take n int_tys) ty]
- where
- int_tys = integerTy : int_tys
-
-podTyCon = pcDataTyCon podTyConKey pRELUDE_BUILTIN "Pod" [alpha_tv] []
-\end{code}
-
-%************************************************************************
-%* *
-\section[Podized_POD]{The ``Podized model'' of a Pod}
-%* *
-%************************************************************************
-Theres a small problem with the following code, I wonder if anyone can help??
-
-I have defined podized versions of TyCons, by wrapping a TyCon and an Int in
-a PodizedTyCon (similiar to technique used for Ids). This is helpfull because
-when tycons are attached to cases, they show that they are podized (I want
-to preserve the info). TyCons are also used in the unitype world, the problem
-being if I want a podized dictionary - I cannt just call getUniDataTyCon
-to get me the dictionaries TyCon - it doesnt have one :-( What I've therefore
-done is get the tycon out of a unitype if it has one, otherwise I use a
-default podizedTyConKey which means the things podized, but dont ask anything
-about it - (also for polymorphic types).
-
-ToDo(hilly): Using @getUniDataTyCon_maybe@ doesnt seem a good way of doing
- things...
-\begin{code}
-mkPodizedPodNTy:: Int -> UniType -> UniType
-mkPodizedPodNTy n ty
- = case (getUniDataTyCon_maybe ty) of
- Nothing ->let tc = pcDataTyCon (podizedPodTyConKey n) pRELUDE_BUILTIN
- ("PodizedUnk"++show n) [alpha_tv] []
- in UniData tc [ty]
-
- Just (tycon,_,_) ->UniData (mkPodizedPodTyCon n tycon) [ty]
-
-\end{code}
-%************************************************************************
-%* *
-\section[Podized_POD]{The ``Interface model'' of a Pod}
-%* *
-%************************************************************************
-\begin{code}
-mkInterfacePodNTy n ty
- = UniData (interfacePodTyCon n) [mkPodizedPodNTy n ty]
-
-interfacePodTyCon n
- = pcDataTyCon interfacePodTyConKey pRELUDE_BUILTIN
- "InterPod" [alpha_tv] [mKINTERPOD_ID n]
-
-mKINTERPOD_ID n
- = pcDataCon interfacePodDataConKey pRELUDE_BUILTIN "MkInterPod"
- [] [] [mkPodizedPodNTy n boolTy] (interfacePodTyCon n) nullSpecEnv
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1992
-%
-\section[TyProcessor]{The processor datatypes}
-
-This is used only for ``Data Parallel Haskell.''
-
-\begin{code}
-#include "HsVersions.h"
-
-module TyProcs where
-
-import PrelFuns -- help functions, types and things
-import PrelUniqs
-
-import AbsUniType ( applyTyCon, mkProcessorTyCon )
-import Util
-
-mkProcessorTy :: [UniType] -> UniType -> UniType
-mkProcessorTy tys ty
- = applyTyCon (mkProcessorTyCon (length tys)) (tys++[ty])
-
-processor1TyCon = mkProcessorTyCon (1::Int)
-processor2TyCon = mkProcessorTyCon (2::Int)
-processor3TyCon = mkProcessorTyCon (3::Int)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TysPrim where
-import TyCon(TyCon)
-import UniType(UniType)
-addrPrimTy :: UniType
-addrPrimTyCon :: TyCon
-arrayPrimTyCon :: TyCon
-byteArrayPrimTy :: UniType
-byteArrayPrimTyCon :: TyCon
-charPrimTy :: UniType
-charPrimTyCon :: TyCon
-doublePrimTy :: UniType
-doublePrimTyCon :: TyCon
-floatPrimTy :: UniType
-floatPrimTyCon :: TyCon
-intPrimTy :: UniType
-intPrimTyCon :: TyCon
-mallocPtrPrimTyCon :: TyCon
-mkArrayPrimTy :: UniType -> UniType
-mkMutableArrayPrimTy :: UniType -> UniType -> UniType
-mkMutableByteArrayPrimTy :: UniType -> UniType
-mkStablePtrPrimTy :: UniType -> UniType
-mkStatePrimTy :: UniType -> UniType
-mkSynchVarPrimTy :: UniType -> UniType -> UniType
-mutableArrayPrimTyCon :: TyCon
-mutableByteArrayPrimTyCon :: TyCon
-realWorldStatePrimTy :: UniType
-realWorldTy :: UniType
-realWorldTyCon :: TyCon
-stablePtrPrimTyCon :: TyCon
-statePrimTyCon :: TyCon
-synchVarPrimTyCon :: TyCon
-voidPrimTy :: UniType
-wordPrimTy :: UniType
-wordPrimTyCon :: TyCon
-
%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[TysPrim]{Wired-in knowledge about primitive types}
module TysPrim where
-import PrelFuns -- help functions, types and things
-import PrimKind
-
-import AbsUniType ( applyTyCon )
+import Ubiq
+
+import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind )
+import NameTypes ( mkPreludeCoreName, FullName )
+import PrelMods ( pRELUDE_BUILTIN )
+import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
+import TyCon ( mkPrimTyCon, mkDataTyCon,
+ ConsVisible(..), NewOrData(..) )
+import TyVar ( GenTyVar(..), alphaTyVars )
+import Type ( applyTyCon, mkTyVarTy )
+import Usage ( usageOmega )
import Unique
-import Util
+
+\end{code}
+
+\begin{code}
+alphaTys = map mkTyVarTy alphaTyVars
+(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+-- only used herein
+pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ([PrimRep] -> PrimRep) -> TyCon
+pcPrimTyCon key name arity{-UNUSED-} kind_fn{-UNUSED-}
+ = mkPrimTyCon key full_name mkUnboxedTypeKind
+ where
+ full_name = mkPreludeCoreName pRELUDE_BUILTIN name
+
+
charPrimTy = applyTyCon charPrimTyCon []
-charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 (\ [] -> CharKind)
+charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 (\ [] -> CharRep)
intPrimTy = applyTyCon intPrimTyCon []
-intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 (\ [] -> IntKind)
+intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 (\ [] -> IntRep)
wordPrimTy = applyTyCon wordPrimTyCon []
-wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 (\ [] -> WordKind)
+wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 (\ [] -> WordRep)
addrPrimTy = applyTyCon addrPrimTyCon []
-addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 (\ [] -> AddrKind)
+addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 (\ [] -> AddrRep)
floatPrimTy = applyTyCon floatPrimTyCon []
-floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 (\ [] -> FloatKind)
+floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 (\ [] -> FloatRep)
doublePrimTy = applyTyCon doublePrimTyCon []
-doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 (\ [] -> DoubleKind)
+doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 (\ [] -> DoubleRep)
+\end{code}
+
+@PrimitiveKinds@ are used in @PrimitiveOps@, for which we often need
+to reconstruct various type information. (It's slightly more
+convenient/efficient to make type info from kinds, than kinds [etc.]
+from type info.)
+
+\begin{code}
+getPrimRepInfo ::
+ PrimRep -> (String, -- tag string
+ Type, TyCon) -- prim type and tycon
+
+getPrimRepInfo CharRep = ("Char", charPrimTy, charPrimTyCon)
+getPrimRepInfo IntRep = ("Int", intPrimTy, intPrimTyCon)
+getPrimRepInfo WordRep = ("Word", wordPrimTy, wordPrimTyCon)
+getPrimRepInfo AddrRep = ("Addr", addrPrimTy, addrPrimTyCon)
+getPrimRepInfo FloatRep = ("Float", floatPrimTy, floatPrimTyCon)
+getPrimRepInfo DoubleRep = ("Double", doublePrimTy, doublePrimTyCon)
\end{code}
%************************************************************************
voidPrimTy = applyTyCon voidPrimTyCon []
where
voidPrimTyCon = pcPrimTyCon voidPrimTyConKey SLIT("Void#") 0
- (\ [] -> VoidKind)
+ (\ [] -> VoidRep)
\end{code}
%************************************************************************
\begin{code}
mkStatePrimTy ty = applyTyCon statePrimTyCon [ty]
statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1
- (\ [s_kind] -> VoidKind)
+ (\ [s_kind] -> VoidRep)
\end{code}
@_RealWorld@ is deeply magical. It {\em is primitive}, but it
{\em is not unboxed}.
\begin{code}
-realWorldTy = applyTyCon realWorldTyCon []
+realWorldTy = applyTyCon realWorldTyCon []
realWorldTyCon
- = pcDataTyCon realWorldTyConKey pRELUDE_BUILTIN SLIT("_RealWorld") []
+ = mkDataTyCon realWorldTyConKey mkBoxedTypeKind full_name
+ [{-no tyvars-}]
+ [{-no context-}]
[{-no data cons!-}] -- we tell you *nothing* about this guy
+ [{-no derivings-}]
+ ConsInvisible
+ DataType
+ where
+ full_name = mkPreludeCoreName pRELUDE_BUILTIN SLIT("_RealWorld")
realWorldStatePrimTy = mkStatePrimTy realWorldTy
\end{code}
\begin{code}
arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1
- (\ [elt_kind] -> ArrayKind)
+ (\ [elt_kind] -> ArrayRep)
byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0
- (\ [] -> ByteArrayKind)
+ (\ [] -> ByteArrayRep)
mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2
- (\ [s_kind, elt_kind] -> ArrayKind)
+ (\ [s_kind, elt_kind] -> ArrayRep)
mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1
- (\ [s_kind] -> ByteArrayKind)
+ (\ [s_kind] -> ByteArrayRep)
mkArrayPrimTy elt = applyTyCon arrayPrimTyCon [elt]
byteArrayPrimTy = applyTyCon byteArrayPrimTyCon []
\begin{code}
synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2
- (\ [s_kind, elt_kind] -> PtrKind)
+ (\ [s_kind, elt_kind] -> PtrRep)
mkSynchVarPrimTy s elt = applyTyCon synchVarPrimTyCon [s, elt]
\end{code}
\begin{code}
stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1
- (\ [elt_kind] -> StablePtrKind)
+ (\ [elt_kind] -> StablePtrRep)
mkStablePtrPrimTy ty = applyTyCon stablePtrPrimTyCon [ty]
\end{code}
\begin{code}
mallocPtrPrimTyCon = pcPrimTyCon mallocPtrPrimTyConKey SLIT("MallocPtr#") 0
- (\ [] -> MallocPtrKind)
+ (\ [] -> MallocPtrRep)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TysWiredIn where
-import Id(Id)
-import TyCon(TyCon)
-import UniType(UniType)
-addrDataCon :: Id
-addrTy :: UniType
-addrTyCon :: TyCon
-boolTy :: UniType
-boolTyCon :: TyCon
-charDataCon :: Id
-charTy :: UniType
-charTyCon :: TyCon
-cmpTagTy :: UniType
-cmpTagTyCon :: TyCon
-consDataCon :: Id
-doubleDataCon :: Id
-doubleTy :: UniType
-doubleTyCon :: TyCon
-eqPrimDataCon :: Id
-falseDataCon :: Id
-floatDataCon :: Id
-floatTy :: UniType
-floatTyCon :: TyCon
-getStatePairingConInfo :: UniType -> (Id, UniType)
-gtPrimDataCon :: Id
-intDataCon :: Id
-intTy :: UniType
-intTyCon :: TyCon
-integerDataCon :: Id
-integerTy :: UniType
-integerTyCon :: TyCon
-liftDataCon :: Id
-liftTyCon :: TyCon
-listTyCon :: TyCon
-ltPrimDataCon :: Id
-mallocPtrTyCon :: TyCon
-mkLiftTy :: UniType -> UniType
-mkListTy :: UniType -> UniType
-mkPrimIoTy :: UniType -> UniType
-mkStateTransformerTy :: UniType -> UniType -> UniType
-mkTupleTy :: Int -> [UniType] -> UniType
-nilDataCon :: Id
-primIoTyCon :: TyCon
-ratioDataCon :: Id
-ratioTyCon :: TyCon
-rationalTy :: UniType
-rationalTyCon :: TyCon
-realWorldStateTy :: UniType
-return2GMPsTyCon :: TyCon
-returnIntAndGMPTyCon :: TyCon
-stTyCon :: TyCon
-stablePtrTyCon :: TyCon
-stateAndAddrPrimTyCon :: TyCon
-stateAndArrayPrimTyCon :: TyCon
-stateAndByteArrayPrimTyCon :: TyCon
-stateAndCharPrimTyCon :: TyCon
-stateAndDoublePrimTyCon :: TyCon
-stateAndFloatPrimTyCon :: TyCon
-stateAndIntPrimTyCon :: TyCon
-stateAndMallocPtrPrimTyCon :: TyCon
-stateAndMutableArrayPrimTyCon :: TyCon
-stateAndMutableByteArrayPrimTyCon :: TyCon
-stateAndPtrPrimTyCon :: TyCon
-stateAndStablePtrPrimTyCon :: TyCon
-stateAndSynchVarPrimTyCon :: TyCon
-stateAndWordPrimTyCon :: TyCon
-stateDataCon :: Id
-stateTyCon :: TyCon
-stringTy :: UniType
-stringTyCon :: TyCon
-trueDataCon :: Id
-unitTy :: UniType
-wordDataCon :: Id
-wordTy :: UniType
-wordTyCon :: TyCon
-
charDataCon,
charTy,
charTyCon,
- cmpTagTy,
- cmpTagTyCon,
consDataCon,
doubleDataCon,
doubleTy,
doubleTyCon,
- eqPrimDataCon,
+ eqDataCon,
falseDataCon,
floatDataCon,
floatTy,
floatTyCon,
getStatePairingConInfo,
- gtPrimDataCon,
+ gtDataCon,
intDataCon,
intTy,
intTyCon,
liftDataCon,
liftTyCon,
listTyCon,
- ltPrimDataCon,
+ ltDataCon,
mallocPtrTyCon,
mkLiftTy,
mkListTy,
mkStateTransformerTy,
mkTupleTy,
nilDataCon,
+ orderingTy,
+ orderingTyCon,
primIoTyCon,
ratioDataCon,
ratioTyCon,
wordDataCon,
wordTy,
wordTyCon
+
) where
-import Pretty --ToDo:rm debugging only
+import Ubiq
+import TyLoop ( mkDataCon, StrictnessMark(..) )
-import PrelFuns -- help functions, types and things
+-- friends:
+import PrelMods
import TysPrim
-import AbsUniType ( applyTyCon, mkTupleTyCon, mkSynonymTyCon,
- getUniDataTyCon_maybe, mkSigmaTy, TyCon
- , pprUniType --ToDo: rm debugging only
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
- )
-import IdInfo
-import Maybes ( Maybe(..) )
+-- others:
+import SpecEnv ( SpecEnv(..) )
+import NameTypes ( mkPreludeCoreName, mkShortName )
+import Kind ( mkBoxedTypeKind, mkArrowKind )
+import SrcLoc ( mkBuiltinSrcLoc )
+import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
+ ConsVisible(..), NewOrData(..), TyCon )
+import Type ( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy,
+ mkFunTys, maybeAppDataTyCon,
+ GenType(..), ThetaType(..), TauType(..) )
+import TyVar ( getTyVarKind, alphaTyVar, betaTyVar )
import Unique
-import Util
+import Util ( assoc, panic )
+
+nullSpecEnv = error "TysWiredIn:nullSpecEnv = "
+addOneToSpecEnv = error "TysWiredIn:addOneToSpecEnv = "
+pc_gen_specs = error "TysWiredIn:pc_gen_specs "
+mkSpecInfo = error "TysWiredIn:SpecInfo"
+
+pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> [Id] -> TyCon
+pcDataTyCon key mod name tyvars cons
+ = mkDataTyCon key tycon_kind full_name tyvars
+ [{-no context-}] cons [{-no derivings-}]
+ ConsVisible DataType
+ where
+ full_name = mkPreludeCoreName mod name
+ tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind tyvars
+
+pcDataCon :: Unique{-DataConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
+pcDataCon key mod name tyvars context arg_tys tycon specenv
+ = mkDataCon key (mkPreludeCoreName mod name)
+ [ NotMarkedStrict | a <- arg_tys ]
+ tyvars context arg_tys tycon
+ -- specenv
+
+pcGenerateDataSpecs :: Type -> SpecEnv
+pcGenerateDataSpecs ty
+ = pc_gen_specs False err err err ty
+ where
+ err = panic "PrelUtils:GenerateDataSpecs"
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-charTy = UniData charTyCon []
+charTy = mkTyConTy charTyCon
charTyCon = pcDataTyCon charTyConKey pRELUDE_BUILTIN SLIT("Char") [] [charDataCon]
charDataCon = pcDataCon charDataConKey pRELUDE_BUILTIN SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv
\end{code}
\begin{code}
-intTy = UniData intTyCon []
+intTy = mkTyConTy intTyCon
intTyCon = pcDataTyCon intTyConKey pRELUDE_BUILTIN SLIT("Int") [] [intDataCon]
-intDataCon = pcDataCon intDataConKey pRELUDE_BUILTIN SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv
+intDataCon = pcDataCon intDataConKey pRELUDE_BUILTIN SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv
\end{code}
\begin{code}
-wordTy = UniData wordTyCon []
+wordTy = mkTyConTy wordTyCon
wordTyCon = pcDataTyCon wordTyConKey pRELUDE_BUILTIN SLIT("_Word") [] [wordDataCon]
wordDataCon = pcDataCon wordDataConKey pRELUDE_BUILTIN SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv
\end{code}
\begin{code}
-addrTy = UniData addrTyCon []
+addrTy = mkTyConTy addrTyCon
addrTyCon = pcDataTyCon addrTyConKey pRELUDE_BUILTIN SLIT("_Addr") [] [addrDataCon]
addrDataCon = pcDataCon addrDataConKey pRELUDE_BUILTIN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
\end{code}
\begin{code}
-floatTy = UniData floatTyCon []
+floatTy = mkTyConTy floatTyCon
floatTyCon = pcDataTyCon floatTyConKey pRELUDE_BUILTIN SLIT("Float") [] [floatDataCon]
floatDataCon = pcDataCon floatDataConKey pRELUDE_BUILTIN SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv
\end{code}
\begin{code}
-doubleTy = UniData doubleTyCon []
+doubleTy = mkTyConTy doubleTyCon
doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE_BUILTIN SLIT("Double") [] [doubleDataCon]
doubleDataCon = pcDataCon doubleDataConKey pRELUDE_BUILTIN SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv
mkStateTy ty = applyTyCon stateTyCon [ty]
realWorldStateTy = mkStateTy realWorldTy -- a common use
-stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") [alpha_tv] [stateDataCon]
+stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") [alphaTyVar] [stateDataCon]
stateDataCon
= pcDataCon stateDataConKey pRELUDE_BUILTIN SLIT("S#")
- [alpha_tv] [] [mkStatePrimTy alpha] stateTyCon nullSpecEnv
-\end{code}
-
-\begin{code}
-{- OLD:
-byteArrayTyCon
- = pcDataTyCon byteArrayTyConKey pRELUDE_ARRAY SLIT("_ByteArray")
- [alpha_tv] [byteArrayDataCon]
-
-byteArrayDataCon
- = pcDataCon byteArrayDataConKey pRELUDE_ARRAY SLIT("_ByteArray")
- [alpha_tv] []
- [mkTupleTy 2 [alpha, alpha], byteArrayPrimTy]
- byteArrayTyCon nullSpecEnv
--}
-\end{code}
-
-\begin{code}
-{- OLD:
-mutableArrayTyCon
- = pcDataTyCon mutableArrayTyConKey gLASGOW_ST SLIT("_MutableArray")
- [alpha_tv, beta_tv, gamma_tv] [mutableArrayDataCon]
- where
- mutableArrayDataCon
- = pcDataCon mutableArrayDataConKey gLASGOW_ST SLIT("_MutableArray")
- [alpha_tv, beta_tv, gamma_tv] []
- [mkTupleTy 2 [beta, beta], applyTyCon mutableArrayPrimTyCon [alpha, gamma]]
- mutableArrayTyCon nullSpecEnv
--}
-\end{code}
-
-\begin{code}
-{-
-mutableByteArrayTyCon
- = pcDataTyCon mutableByteArrayTyConKey gLASGOW_ST SLIT("_MutableByteArray")
- [alpha_tv, beta_tv] [mutableByteArrayDataCon]
-
-mutableByteArrayDataCon
- = pcDataCon mutableByteArrayDataConKey gLASGOW_ST SLIT("_MutableByteArray")
- [alpha_tv, beta_tv] []
- [mkTupleTy 2 [beta, beta], mkMutableByteArrayPrimTy alpha]
- mutableByteArrayTyCon nullSpecEnv
--}
+ [alphaTyVar] [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
\end{code}
\begin{code}
stablePtrTyCon
= pcDataTyCon stablePtrTyConKey gLASGOW_MISC SLIT("_StablePtr")
- [alpha_tv] [stablePtrDataCon]
+ [alphaTyVar] [stablePtrDataCon]
where
stablePtrDataCon
= pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr")
- [alpha_tv] [] [applyTyCon stablePtrPrimTyCon [alpha]] stablePtrTyCon nullSpecEnv
+ [alphaTyVar] [] [applyTyCon stablePtrPrimTyCon [alphaTy]] stablePtrTyCon nullSpecEnv
\end{code}
\begin{code}
@Integer@ and its pals are not really primitive. @Integer@ itself, first:
\begin{code}
-integerTy :: UniType
-integerTy = UniData integerTyCon []
+integerTy :: GenType t u
+integerTy = mkTyConTy integerTyCon
integerTyCon = pcDataTyCon integerTyConKey pRELUDE_BUILTIN SLIT("Integer") [] [integerDataCon]
-#ifndef DPH
integerDataCon = pcDataCon integerDataConKey pRELUDE_BUILTIN SLIT("J#")
[] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon nullSpecEnv
-#else
--- DPH: For the time being we implement Integers in the same way as Ints.
-integerDataCon = pcDataCon integerDataConKey pRELUDE_BUILTIN SLIT("J#")
- [] [] [intPrimTy] integerTyCon nullSpecEnv
-#endif {- Data Parallel Haskell -}
\end{code}
And the other pairing types:
\begin{code}
stateAndPtrPrimTyCon
= pcDataTyCon stateAndPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
- [alpha_tv, beta_tv] [stateAndPtrPrimDataCon]
+ [alphaTyVar, betaTyVar] [stateAndPtrPrimDataCon]
stateAndPtrPrimDataCon
= pcDataCon stateAndPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
- [alpha_tv, beta_tv] [] [mkStatePrimTy alpha, beta]
+ [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, betaTy]
stateAndPtrPrimTyCon nullSpecEnv
stateAndCharPrimTyCon
= pcDataTyCon stateAndCharPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
- [alpha_tv] [stateAndCharPrimDataCon]
+ [alphaTyVar] [stateAndCharPrimDataCon]
stateAndCharPrimDataCon
= pcDataCon stateAndCharPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
- [alpha_tv] [] [mkStatePrimTy alpha, charPrimTy]
+ [alphaTyVar] [] [mkStatePrimTy alphaTy, charPrimTy]
stateAndCharPrimTyCon nullSpecEnv
stateAndIntPrimTyCon
= pcDataTyCon stateAndIntPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
- [alpha_tv] [stateAndIntPrimDataCon]
+ [alphaTyVar] [stateAndIntPrimDataCon]
stateAndIntPrimDataCon
= pcDataCon stateAndIntPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
- [alpha_tv] [] [mkStatePrimTy alpha, intPrimTy]
+ [alphaTyVar] [] [mkStatePrimTy alphaTy, intPrimTy]
stateAndIntPrimTyCon nullSpecEnv
stateAndWordPrimTyCon
= pcDataTyCon stateAndWordPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
- [alpha_tv] [stateAndWordPrimDataCon]
+ [alphaTyVar] [stateAndWordPrimDataCon]
stateAndWordPrimDataCon
= pcDataCon stateAndWordPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
- [alpha_tv] [] [mkStatePrimTy alpha, wordPrimTy]
+ [alphaTyVar] [] [mkStatePrimTy alphaTy, wordPrimTy]
stateAndWordPrimTyCon nullSpecEnv
stateAndAddrPrimTyCon
= pcDataTyCon stateAndAddrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
- [alpha_tv] [stateAndAddrPrimDataCon]
+ [alphaTyVar] [stateAndAddrPrimDataCon]
stateAndAddrPrimDataCon
= pcDataCon stateAndAddrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
- [alpha_tv] [] [mkStatePrimTy alpha, addrPrimTy]
+ [alphaTyVar] [] [mkStatePrimTy alphaTy, addrPrimTy]
stateAndAddrPrimTyCon nullSpecEnv
stateAndStablePtrPrimTyCon
= pcDataTyCon stateAndStablePtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
- [alpha_tv, beta_tv] [stateAndStablePtrPrimDataCon]
+ [alphaTyVar, betaTyVar] [stateAndStablePtrPrimDataCon]
stateAndStablePtrPrimDataCon
= pcDataCon stateAndStablePtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
- [alpha_tv, beta_tv] []
- [mkStatePrimTy alpha, applyTyCon stablePtrPrimTyCon [beta]]
+ [alphaTyVar, betaTyVar] []
+ [mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
stateAndStablePtrPrimTyCon nullSpecEnv
stateAndMallocPtrPrimTyCon
= pcDataTyCon stateAndMallocPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#")
- [alpha_tv] [stateAndMallocPtrPrimDataCon]
+ [alphaTyVar] [stateAndMallocPtrPrimDataCon]
stateAndMallocPtrPrimDataCon
= pcDataCon stateAndMallocPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#")
- [alpha_tv] []
- [mkStatePrimTy alpha, applyTyCon mallocPtrPrimTyCon []]
+ [alphaTyVar] []
+ [mkStatePrimTy alphaTy, applyTyCon mallocPtrPrimTyCon []]
stateAndMallocPtrPrimTyCon nullSpecEnv
stateAndFloatPrimTyCon
= pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
- [alpha_tv] [stateAndFloatPrimDataCon]
+ [alphaTyVar] [stateAndFloatPrimDataCon]
stateAndFloatPrimDataCon
= pcDataCon stateAndFloatPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
- [alpha_tv] [] [mkStatePrimTy alpha, floatPrimTy]
+ [alphaTyVar] [] [mkStatePrimTy alphaTy, floatPrimTy]
stateAndFloatPrimTyCon nullSpecEnv
stateAndDoublePrimTyCon
= pcDataTyCon stateAndDoublePrimTyConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
- [alpha_tv] [stateAndDoublePrimDataCon]
+ [alphaTyVar] [stateAndDoublePrimDataCon]
stateAndDoublePrimDataCon
= pcDataCon stateAndDoublePrimDataConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
- [alpha_tv] [] [mkStatePrimTy alpha, doublePrimTy]
+ [alphaTyVar] [] [mkStatePrimTy alphaTy, doublePrimTy]
stateAndDoublePrimTyCon nullSpecEnv
\end{code}
\begin{code}
stateAndArrayPrimTyCon
= pcDataTyCon stateAndArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
- [alpha_tv, beta_tv] [stateAndArrayPrimDataCon]
+ [alphaTyVar, betaTyVar] [stateAndArrayPrimDataCon]
stateAndArrayPrimDataCon
= pcDataCon stateAndArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
- [alpha_tv, beta_tv] [] [mkStatePrimTy alpha, mkArrayPrimTy beta]
+ [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
stateAndArrayPrimTyCon nullSpecEnv
stateAndMutableArrayPrimTyCon
= pcDataTyCon stateAndMutableArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
- [alpha_tv, beta_tv] [stateAndMutableArrayPrimDataCon]
+ [alphaTyVar, betaTyVar] [stateAndMutableArrayPrimDataCon]
stateAndMutableArrayPrimDataCon
= pcDataCon stateAndMutableArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
- [alpha_tv, beta_tv] [] [mkStatePrimTy alpha, mkMutableArrayPrimTy alpha beta]
+ [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
stateAndMutableArrayPrimTyCon nullSpecEnv
stateAndByteArrayPrimTyCon
= pcDataTyCon stateAndByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
- [alpha_tv] [stateAndByteArrayPrimDataCon]
+ [alphaTyVar] [stateAndByteArrayPrimDataCon]
stateAndByteArrayPrimDataCon
= pcDataCon stateAndByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
- [alpha_tv] [] [mkStatePrimTy alpha, byteArrayPrimTy]
+ [alphaTyVar] [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
stateAndByteArrayPrimTyCon nullSpecEnv
stateAndMutableByteArrayPrimTyCon
= pcDataTyCon stateAndMutableByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
- [alpha_tv] [stateAndMutableByteArrayPrimDataCon]
+ [alphaTyVar] [stateAndMutableByteArrayPrimDataCon]
stateAndMutableByteArrayPrimDataCon
= pcDataCon stateAndMutableByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
- [alpha_tv] [] [mkStatePrimTy alpha, applyTyCon mutableByteArrayPrimTyCon [alpha]]
+ [alphaTyVar] [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon [alphaTy]]
stateAndMutableByteArrayPrimTyCon nullSpecEnv
stateAndSynchVarPrimTyCon
= pcDataTyCon stateAndSynchVarPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
- [alpha_tv, beta_tv] [stateAndSynchVarPrimDataCon]
+ [alphaTyVar, betaTyVar] [stateAndSynchVarPrimDataCon]
stateAndSynchVarPrimDataCon
= pcDataCon stateAndSynchVarPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
- [alpha_tv, beta_tv] [] [mkStatePrimTy alpha, mkSynchVarPrimTy alpha beta]
+ [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
stateAndSynchVarPrimTyCon nullSpecEnv
\end{code}
\begin{code}
getStatePairingConInfo
- :: UniType -- primitive type
+ :: Type -- primitive type
-> (Id, -- state pair constructor for prim type
- UniType) -- type of state pair
+ Type) -- type of state pair
getStatePairingConInfo prim_ty
- = case (getUniDataTyCon_maybe prim_ty) of
+ = case (maybeAppDataTyCon prim_ty) of
Nothing -> panic "getStatePairingConInfo:1"
Just (prim_tycon, tys_applied, _) ->
let
This is really just an ordinary synonym, except it is ABSTRACT.
\begin{code}
-mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
+mkStateTransformerTy s a = mkSynTy stTyCon [s, a]
stTyCon
- = mkSynonymTyCon
+ = mkSynTyCon
stTyConKey
(mkPreludeCoreName gLASGOW_ST SLIT("_ST"))
+ (panic "TysWiredIn.stTyCon:Kind")
2
- [alpha_tv, beta_tv]
- (mkStateTy alpha `UniFun` mkTupleTy 2 [beta, mkStateTy alpha])
- True -- ToDo: make... *** ABSTRACT ***
+ [alphaTyVar, betaTyVar]
+ (mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy]))
\end{code}
%************************************************************************
%* *
%************************************************************************
-@PrimIO@ and @IO@ really are just a plain synonyms.
+@PrimIO@ and @IO@ really are just plain synonyms.
\begin{code}
-mkPrimIoTy a = applyTyCon primIoTyCon [a]
+mkPrimIoTy a = mkSynTy primIoTyCon [a]
primIoTyCon
- = mkSynonymTyCon
+ = mkSynTyCon
primIoTyConKey
(mkPreludeCoreName pRELUDE_PRIMIO SLIT("PrimIO"))
+ (panic "TysWiredIn.primIoTyCon:Kind")
1
- [alpha_tv]
- (mkStateTransformerTy realWorldTy alpha)
- True -- need not be abstract
+ [alphaTyVar]
+ (mkStateTransformerTy realWorldTy alphaTy)
\end{code}
%************************************************************************
{\em END IDLE SPECULATION BY SIMON}
\begin{code}
-boolTy = UniData boolTyCon []
+boolTy = mkTyConTy boolTyCon
boolTyCon = pcDataTyCon boolTyConKey pRELUDE_CORE SLIT("Bool") [] [falseDataCon, trueDataCon]
%************************************************************************
%* *
-\subsection[TysWiredIn-CMP-TAG]{The @CMP_TAG#@ type (for fast `derived' comparisons)}
+\subsection[TysWiredIn-Ordering]{The @Ordering@ type}
%* *
%************************************************************************
\begin{code}
---------------------------------------------
--- data _CMP_TAG = _LT | _EQ | _GT deriving ()
+-- data Ordering = LT | EQ | GT deriving ()
---------------------------------------------
-cmpTagTy = UniData cmpTagTyCon []
+orderingTy = mkTyConTy orderingTyCon
-cmpTagTyCon = pcDataTyCon cmpTagTyConKey pRELUDE_BUILTIN SLIT("_CMP_TAG") []
- [ltPrimDataCon, eqPrimDataCon, gtPrimDataCon]
+orderingTyCon = pcDataTyCon orderingTyConKey pRELUDE_BUILTIN SLIT("Ordering") []
+ [ltDataCon, eqDataCon, gtDataCon]
-ltPrimDataCon = pcDataCon ltTagDataConKey pRELUDE_BUILTIN SLIT("_LT") [] [] [] cmpTagTyCon nullSpecEnv
-eqPrimDataCon = pcDataCon eqTagDataConKey pRELUDE_BUILTIN SLIT("_EQ") [] [] [] cmpTagTyCon nullSpecEnv
-gtPrimDataCon = pcDataCon gtTagDataConKey pRELUDE_BUILTIN SLIT("_GT") [] [] [] cmpTagTyCon nullSpecEnv
+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}
%************************************************************************
data type:
\begin{verbatim}
data List a = Nil | a : (List a)
+ToDo: data [] a = [] | a : (List a)
+ToDo: data () = ()
+ data (,,) a b c = (,,) a b c
\end{verbatim}
\begin{code}
-mkListTy :: UniType -> UniType
-mkListTy ty = UniData listTyCon [ty]
+mkListTy :: GenType t u -> GenType t u
+mkListTy ty = applyTyCon listTyCon [ty]
-alphaListTy = mkSigmaTy [alpha_tv] [] (mkListTy alpha)
+alphaListTy = mkSigmaTy [alphaTyVar] [] (applyTyCon listTyCon [alphaTy])
-listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("List") [alpha_tv] [nilDataCon, consDataCon]
+listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("[]")
+ [alphaTyVar] [nilDataCon, consDataCon]
-nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("Nil") [alpha_tv] [] [] listTyCon
+nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("[]") [alphaTyVar] [] [] listTyCon
(pcGenerateDataSpecs alphaListTy)
consDataCon = pcDataCon consDataConKey pRELUDE_BUILTIN SLIT(":")
- [alpha_tv] [] [alpha, mkListTy alpha] listTyCon
+ [alphaTyVar] [] [alphaTy, applyTyCon listTyCon [alphaTy]] listTyCon
(pcGenerateDataSpecs alphaListTy)
-\end{code}
-
-This is the @_Build@ data constructor, it does {\em not} appear inside
-listTyCon. It has this type: \tr{((a -> b -> b) -> b -> b) -> [a]}.
-\begin{code}
-{- NOT USED:
-buildDataCon
- = pcDataCon buildDataConKey pRELUDE_BUILTIN "Build"
- [alpha_tv] [] [
- mkSigmaTy [beta_tv] []
- ((alpha `UniFun` (beta `UniFun` beta))
- `UniFun` (beta
- `UniFun` beta))] listTyCon nullSpecEnv
--}
+-- Interesting: polymorphic recursion would help here.
+-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
+-- gets the over-specific type (Type -> Type)
\end{code}
%************************************************************************
\begin{itemize}
\item
-They have a special family of type constructors, of type
-@TyCon@\srcloc{uniType/TyCon.lhs}.
+They have a special family of type constructors, of type @TyCon@
These contain the tycon arity, but don't require a Unique.
\item
They have a special family of constructors, of type
-@Id@\srcloc{basicTypes/Id.lhs}. Again these contain their arity but
-don't need a Unique.
+@Id@. Again these contain their arity but don't need a Unique.
\item
There should be a magic way of generating the info tables and
\end{itemize}
\begin{code}
-mkTupleTy :: Int -> [UniType] -> UniType
+mkTupleTy :: Int -> [GenType t u] -> GenType t u
mkTupleTy arity tys = applyTyCon (mkTupleTyCon arity) tys
-unitTy = mkTupleTy 0 []
+unitTy = mkTupleTy 0 []
\end{code}
%************************************************************************
ToDo: make this (mostly) go away.
\begin{code}
-rationalTy :: UniType
+rationalTy :: GenType t u
-mkRatioTy ty = UniData ratioTyCon [ty]
+mkRatioTy ty = applyTyCon ratioTyCon [ty]
rationalTy = mkRatioTy integerTy
-ratioTyCon = pcDataTyCon ratioTyConKey pRELUDE_RATIO SLIT("Ratio") [alpha_tv] [ratioDataCon]
+ratioTyCon = pcDataTyCon ratioTyConKey pRELUDE_RATIO SLIT("Ratio") [alphaTyVar] [ratioDataCon]
ratioDataCon = pcDataCon ratioDataConKey pRELUDE_RATIO SLIT(":%")
- [alpha_tv] [{-(integralClass,alpha)-}] [alpha, alpha] ratioTyCon nullSpecEnv
+ [alphaTyVar] [{-(integralClass,alphaTy)-}] [alphaTy, alphaTy] ratioTyCon nullSpecEnv
-- context omitted to match lib/prelude/ defn of "data Ratio ..."
rationalTyCon
- = mkSynonymTyCon
+ = mkSynTyCon
rationalTyConKey
(mkPreludeCoreName pRELUDE_RATIO SLIT("Rational"))
+ mkBoxedTypeKind
0 -- arity
[] -- tyvars
rationalTy -- == mkRatioTy integerTy
- True -- unabstract
\end{code}
%************************************************************************
{-
mkLiftTy ty
- = mkSigmaTy tvs theta (UniData liftTyCon [tau])
+ = mkSigmaTy tvs theta (applyTyCon liftTyCon [tau])
where
- (tvs, theta, tau) = splitType ty
+ (tvs, theta, tau) = splitSigmaTy ty
isLiftTy ty
- = case getUniDataTyCon_maybe tau of
+ = case maybeAppDataTyCon tau of
Just (tycon, tys, _) -> tycon == liftTyCon
Nothing -> False
where
- (tvs, theta, tau) = splitType ty
+ (tvs, theta, tau) = splitSigmaTy ty
-}
-alphaLiftTy = mkSigmaTy [alpha_tv] [] (UniData liftTyCon [alpha])
+alphaLiftTy = mkSigmaTy [alphaTyVar] [] (applyTyCon liftTyCon [alphaTy])
liftTyCon
- = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") [alpha_tv] [liftDataCon]
+ = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") [alphaTyVar] [liftDataCon]
liftDataCon
= pcDataCon liftDataConKey pRELUDE_BUILTIN SLIT("_Lift")
- [alpha_tv] [] [alpha] liftTyCon
+ [alphaTyVar] [] [alphaTy] liftTyCon
((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv`
- (SpecInfo [Just realWorldStatePrimTy] 0 bottom))
+ (mkSpecInfo [Just realWorldStatePrimTy] 0 bottom))
where
bottom = panic "liftDataCon:State# _RealWorld"
\end{code}
stringTy = mkListTy charTy
stringTyCon
- = mkSynonymTyCon
+ = mkSynTyCon
stringTyConKey
(mkPreludeCoreName pRELUDE_CORE SLIT("String"))
+ mkBoxedTypeKind
0
[] -- type variables
stringTy
- True -- unabstract
-\end{code}
-
-\begin{code}
-{- UNUSED:
-packedStringTy = applyTyCon packedStringTyCon []
-
-packedStringTyCon
- = pcDataTyCon packedStringTyConKey pRELUDE_PS SLIT("_PackedString") []
- [psDataCon, cpsDataCon]
-
-psDataCon
- = pcDataCon psDataConKey pRELUDE_PS SLIT("_PS")
- [] [] [intPrimTy, byteArrayPrimTy] packedStringTyCon
-
-cpsDataCon
- = pcDataCon cpsDataConKey pRELUDE_PS SLIT("_CPS")
- [] [] [addrPrimTy] packedStringTyCon
--}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CostCentre where
-import CharSeq(CSeq)
-import Id(Id)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import Unpretty(Unpretty(..))
-data CSeq
-data CcKind
-data CostCentre
-data Id
-data IsCafCC = IsCafCC | IsNotCafCC
-data IsDupdCC
-data Labda a
-type Unpretty = CSeq
-cafifyCC :: CostCentre -> CostCentre
-ccFromThisModule :: CostCentre -> _PackedString -> Bool
-ccMentionsId :: CostCentre -> Labda Id
-cmpCostCentre :: CostCentre -> CostCentre -> Int#
-costsAreSubsumed :: CostCentre -> Bool
-currentOrSubsumedCosts :: CostCentre -> Bool
-dontCareCostCentre :: CostCentre
-dupifyCC :: CostCentre -> CostCentre
-isCafCC :: CostCentre -> Bool
-isDictCC :: CostCentre -> Bool
-isDupdCC :: CostCentre -> Bool
-mkAllCafsCC :: _PackedString -> _PackedString -> CostCentre
-mkAllDictsCC :: _PackedString -> _PackedString -> Bool -> CostCentre
-mkAutoCC :: Id -> _PackedString -> _PackedString -> IsCafCC -> CostCentre
-mkDictCC :: Id -> _PackedString -> _PackedString -> IsCafCC -> CostCentre
-mkUserCC :: _PackedString -> _PackedString -> _PackedString -> CostCentre
-noCostCentre :: CostCentre
-noCostCentreAttached :: CostCentre -> Bool
-overheadCostCentre :: CostCentre
-preludeCafsCostCentre :: CostCentre
-preludeDictsCostCentre :: Bool -> CostCentre
-setToAbleCostCentre :: CostCentre -> Bool
-showCostCentre :: PprStyle -> Bool -> CostCentre -> [Char]
-subsumedCosts :: CostCentre
-unCafifyCC :: CostCentre -> CostCentre
-uppCostCentre :: PprStyle -> Bool -> CostCentre -> CSeq
-uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> CSeq
-useCurrentCostCentre :: CostCentre
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CostCentre]{The @CostCentre@ data type}
uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing
- cmpCostCentre, -- used for removing dups in a list
-
- Id, Maybe, Unpretty(..), CSeq
+ cmpCostCentre -- used for removing dups in a list
) where
-import CmdLineOpts ( GlobalSwitch(..) )
-import CLabelInfo ( identToC, stringToC )
-import Id ( cmpId, showId, pprIdInUnfolding,
- externallyVisibleId, Id
- )
+import Id ( externallyVisibleId, GenId, Id(..) )
+import CStrings ( identToC, stringToC )
import Maybes ( Maybe(..) )
import Outputable
import Pretty ( ppShow, prettyToUn )
+import PprStyle ( PprStyle(..) )
import UniqSet
import Unpretty
import Util
+import Ubiq
+showId = panic "Whoops"
+pprIdInUnfolding = panic "Whoops"
\end{code}
\begin{code}
mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
-mkUserCC cc_name module_name group_name
+mkUserCC cc_name module_name group_name
= NormalCC (UserCC cc_name) module_name group_name
AnOriginalCC IsNotCafCC{-might be changed-}
tag_CC DontCareCC = ILIT(7)
-- some BUG avoidance here...
- tag_CC NoCostCentre = case (panic "tag_CC:NoCostCentre") of { c -> tag_CC c }
- tag_CC SubsumedCosts = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c }
- tag_CC CurrentCC = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c }
+ tag_CC NoCostCentre = panic# "tag_CC:NoCostCentre"
+ tag_CC SubsumedCosts = panic# "tag_CC:SubsumedCosts"
+ tag_CC CurrentCC = panic# "tag_CC:SubsumedCosts"
cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2
-cmp_kind (AutoCC i1) (AutoCC i2) = cmpId i1 i2
-cmp_kind (DictCC i1) (DictCC i2) = cmpId i1 i2
+cmp_kind (AutoCC i1) (AutoCC i2) = cmp i1 i2
+cmp_kind (DictCC i1) (DictCC i2) = cmp i1 i2
cmp_kind other_1 other_2
= let
tag1 = tag_CcKind other_1
uppCostCentre :: PprStyle -> Bool -> CostCentre -> Unpretty
uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty
-showCostCentre (PprUnfolding _) print_as_string cc
+showCostCentre PprUnfolding print_as_string cc
= ASSERT(not print_as_string) -- we never "print as string w/ Unfolding"
ASSERT(not (noCostCentreAttached cc))
ASSERT(not (currentOrSubsumedCosts cc))
Printing unfoldings is sufficiently weird that we do it separately.
This should only apply to CostCentres that can be ``set to'' (cf
-@setToAbleCostCentre@). That excludes CAFs and
+@setToAbleCostCentre@). That excludes CAFs and
`overhead'---which are added at the very end---but includes dictionaries.
Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info;
even if we won't ultimately do a \tr{SET_CCC} from it.
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SCCauto where
-import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import PreludePS(_PackedString)
-addAutoCostCentres :: (GlobalSwitch -> SwitchResult) -> _PackedString -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[SCCauto]{Automated SCC annotations}
Automatic insertion of \tr{_scc_} annotations for top-level bindings.
Automatic insertion of \tr{_scc_} annotations on CAFs is better left
-until STG land. We do DICT annotations there, too, but maybe
-that will turn out to be a bummer... (WDP 94/06)
+until STG land. We do DICT annotations there, too, but maybe that
+will turn out to be a bummer... (WDP 94/06)
This is a Core-to-Core pass (usually run {\em last}).
module SCCauto ( addAutoCostCentres ) where
-import CmdLineOpts
-import Id ( isTopLevId )
-import PlainCore
+import Ubiq{-uitous-}
+
+import CmdLineOpts ( opt_AutoSccsOnAllToplevs,
+ opt_AutoSccsOnExportedToplevs,
+ opt_SccGroup
+ )
+import CoreSyn
+import Id ( isTopLevId, GenId{-instances-} )
import Outputable ( isExported )
-import CostCentre -- ( mkAutoCC )
-import Util -- for pragmas only
+import CostCentre ( mkAutoCC, IsCafCC(..) )
\end{code}
\begin{code}
addAutoCostCentres
- :: (GlobalSwitch -> SwitchResult) -- cmd-line switches
- -> FAST_STRING -- module name
- -> [PlainCoreBinding] -- input
- -> [PlainCoreBinding] -- output
+ :: FAST_STRING -- module name
+ -> [CoreBinding] -- input
+ -> [CoreBinding] -- output
-addAutoCostCentres sw_chkr mod_name binds
+addAutoCostCentres mod_name binds
= if not doing_something then
binds -- now *that* was quick...
else
where
doing_something = auto_all_switch_on || auto_exported_switch_on
- auto_all_switch_on = switchIsOn sw_chkr AutoSccsOnAllToplevs -- only use!
- auto_exported_switch_on = switchIsOn sw_chkr AutoSccsOnExportedToplevs -- only use!
+ auto_all_switch_on = opt_AutoSccsOnAllToplevs -- only use!
+ auto_exported_switch_on = opt_AutoSccsOnExportedToplevs -- only use!
- grp_name = case (stringSwitchSet sw_chkr SccGroup) of
- Just xx -> _PK_ xx
- Nothing -> mod_name -- default: module name
+ grp_name
+ = case opt_SccGroup of
+ Just xx -> xx
+ Nothing -> mod_name -- default: module name
-----------------------------
- scc_top_bind (CoNonRec binder rhs)
- = CoNonRec binder (scc_auto binder rhs)
+ scc_top_bind (NonRec binder rhs)
+ = NonRec binder (scc_auto binder rhs)
- scc_top_bind (CoRec pairs)
- = CoRec (map scc_pair pairs)
+ scc_top_bind (Rec pairs)
+ = Rec (map scc_pair pairs)
where
scc_pair (binder, rhs) = (binder, scc_auto binder rhs)
scc_auto binder rhs
= if isTopLevId binder
&& (auto_all_switch_on || isExported binder)
- then scc_rhs rhs
+ then scc_rhs rhs
else rhs
where
-- park auto SCC inside lambdas; don't put one there
scc_rhs rhs
= let
- (tyvars, vars, body) = digForLambdas rhs
+ (usevars, tyvars, vars, body) = digForLambdas rhs
in
case body of
- CoSCC _ _ -> rhs -- leave it
- CoCon _ _ _ --??? | null vars
- -> rhs
- _ -> mkFunction tyvars vars
- (CoSCC (mkAutoCC binder mod_name grp_name IsNotCafCC) body)
+ SCC _ _ -> rhs -- leave it
+ Con _ _ -> rhs
+ _ -> mkUseLam usevars (mkLam tyvars vars
+ (SCC (mkAutoCC binder mod_name grp_name IsNotCafCC) body))
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SCCfinal where
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import Id(Id)
-import PreludePS(_PackedString)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgBinding)
-stgMassageForProfiling :: _PackedString -> _PackedString -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [StgBinding Id Id] -> (([CostCentre], [CostCentre]), [StgBinding Id Id])
-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
%
-\section[SCCfinal]{Modify and collect code generation for final StgProgram}
+\section[SCCfinal]{Modify and collect code generation for final STG program}
This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
import Pretty -- ToDo: rm (debugging only)
-import AbsUniType ( isDictTy, getUniDataTyCon_maybe,
- isTupleTyCon, isFunType, getTauType,
- splitType -- pragmas
- )
+import Type ( isFunType, getTauType )
import CmdLineOpts
import CostCentre
-import Id ( mkSysLocal, getIdUniType )
+import Id ( mkSysLocal, idType )
import SrcLoc ( mkUnknownSrcLoc )
import StgSyn
-import SplitUniq
+import UniqSupply
import UniqSet ( emptyUniqSet
IF_ATTACK_PRAGMAS(COMMA emptyUFM)
)
-import Unique
import Util
infixr 9 `thenMM`, `thenMM_`
stgMassageForProfiling
:: FAST_STRING -> FAST_STRING -- module name, group name
- -> SplitUniqSupply -- unique supply
+ -> UniqSupply -- unique supply
-> (GlobalSwitch -> Bool) -- command-line opts checker
- -> [PlainStgBinding] -- input
- -> (CollectedCCs, [PlainStgBinding])
+ -> [StgBinding] -- input
+ -> (CollectedCCs, [StgBinding])
stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
= let
((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
where
do_auto_sccs_on_cafs = sw_chkr AutoSccsOnIndividualCafs -- only use!
---UNUSED: do_auto_sccs_on_dicts = sw_chkr AutoSccsOnIndividualDicts -- only use! ** UNUSED really **
doing_prelude = sw_chkr CompilingPrelude
all_cafs_cc = if doing_prelude
else mkAllCafsCC mod_name grp_name
----------
- do_top_binding :: PlainStgBinding -> MassageM PlainStgBinding
+ do_top_binding :: StgBinding -> MassageM StgBinding
- do_top_binding (StgNonRec b rhs)
+ do_top_binding (StgNonRec b rhs)
= do_top_rhs b rhs `thenMM` \ rhs' ->
returnMM (StgNonRec b rhs')
= mapMM do_pair pairs `thenMM` \ pairs2 ->
returnMM (StgRec pairs2)
where
- do_pair (b, rhs)
+ do_pair (b, rhs)
= do_top_rhs b rhs `thenMM` \ rhs2 ->
returnMM (b, rhs2)
----------
- do_top_rhs :: Id -> PlainStgRhs -> MassageM PlainStgRhs
+ do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
- do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgConApp con args lvs)))
+ do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
-- top-level _scc_ around nothing but static data; toss it -- it's pointless
= returnMM (StgRhsCon dontCareCostCentre con args)
do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc expr))
--- OLD:
--- | noCostCentreAttached rhs_cc || currentOrSubsumedCosts rhs_cc
--- -- doubtful guard... ToDo?
-- Top level CAF with explicit scc expression. Attach CAF
-- cost centre to StgRhsClosure and collect.
= let
- calved_cc = cafifyCC cc
+ calved_cc = cafifyCC cc
in
collectCC calved_cc `thenMM_`
set_prevailing_cc calved_cc (
set_prevailing_cc cc2 (
do_expr body
) `thenMM` \body2 ->
- returnMM (StgRhsClosure cc2 bi fv u [] body2)
+ returnMM (StgRhsClosure cc2 bi fv u [] body2)
do_top_rhs binder (StgRhsClosure _ bi fv u args body@(StgSCC ty cc expr))
-- We blindly use the cc off the _scc_
cc2 = if noCostCentreAttached cc
then subsumedCosts -- it's not a thunk; it is top-level & arity > 0
else cc
- in
+ in
set_prevailing_cc cc2 (
do_expr body
) `thenMM` \ body' ->
-- just slam in dontCareCostCentre
------
- do_expr :: PlainStgExpr -> MassageM PlainStgExpr
+ do_expr :: StgExpr -> MassageM StgExpr
do_expr (StgApp fn args lvs)
= boxHigherOrderArgs (StgApp fn) args lvs
- do_expr (StgConApp con args lvs)
- = boxHigherOrderArgs (StgConApp con) args lvs
+ do_expr (StgCon con args lvs)
+ = boxHigherOrderArgs (StgCon con) args lvs
- do_expr (StgPrimApp op args lvs)
- = boxHigherOrderArgs (StgPrimApp op) args lvs
+ do_expr (StgPrim op args lvs)
+ = boxHigherOrderArgs (StgPrim op) args lvs
do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre!
= collectCC cc `thenMM_`
do_alts alts `thenMM` \ alts' ->
returnMM (StgCase expr' fv1 fv2 uniq alts')
where
- do_alts (StgAlgAlts ty alts def)
+ do_alts (StgAlgAlts ty alts def)
= mapMM do_alt alts `thenMM` \ alts' ->
do_deflt def `thenMM` \ def' ->
returnMM (StgAlgAlts ty alts' def')
= do_expr e `thenMM` \ e' ->
returnMM (id, bs, use_mask, e')
- do_alts (StgPrimAlts ty alts def)
+ do_alts (StgPrimAlts ty alts def)
= mapMM do_alt alts `thenMM` \ alts' ->
do_deflt def `thenMM` \ def' ->
returnMM (StgPrimAlts ty alts' def')
returnMM (l,e')
do_deflt StgNoDefault = returnMM StgNoDefault
- do_deflt (StgBindDefault b is_used e)
+ do_deflt (StgBindDefault b is_used e)
= do_expr e `thenMM` \ e' ->
returnMM (StgBindDefault b is_used e')
returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') )
----------
- do_binding :: PlainStgBinding -> MassageM PlainStgBinding
+ do_binding :: StgBinding -> MassageM StgBinding
- do_binding (StgNonRec b rhs)
+ do_binding (StgNonRec b rhs)
= do_rhs rhs `thenMM` \ rhs' ->
returnMM (StgNonRec b rhs')
= do_rhs rhs `thenMM` \ rhs' ->
returnMM (b, rhs')
- do_rhs :: PlainStgRhs -> MassageM PlainStgRhs
+ do_rhs :: StgRhs -> MassageM StgRhs
-- We play much the same game as we did in do_top_rhs above;
-- but we don't have to worry about cafifying, etc.
-- (ToDo: consolidate??)
{- Patrick says NO: it will mess up our counts (WDP 95/07)
- do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgConApp con args lvs)))
+ do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgCon con args lvs)))
= collectCC cc `thenMM_`
returnMM (StgRhsCon cc con args)
-}
do_rhs (StgRhsCon cc con args)
= use_prevailing_cc_maybe cc `thenMM` \ cc2 ->
- returnMM (StgRhsCon cc2 con args)
+ returnMM (StgRhsCon cc2 con args)
-- ToDo: Box args (if lex) Pass back let binding???
-- Nope: maybe later? WDP 94/06
\end{code}
\begin{code}
boxHigherOrderArgs
- :: ([PlainStgAtom] -> PlainStgLiveVars -> PlainStgExpr)
+ :: ([StgArg] -> StgLiveVars -> StgExpr)
-- An application lacking its arguments and live-var info
- -> [PlainStgAtom] -- arguments which we might box
- -> PlainStgLiveVars -- live var info, which we do *not* try
+ -> [StgArg] -- arguments which we might box
+ -> StgLiveVars -- live var info, which we do *not* try
-- to maintain/update (setStgVarInfo will
-- do that)
- -> MassageM PlainStgExpr
+ -> MassageM StgExpr
boxHigherOrderArgs almost_expr args live_vars
= mapAccumMM do_arg [] args `thenMM` \ (let_bindings, new_args) ->
returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings)
where
---------------
- do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom)
+ do_arg bindings atom@(StgLitArg _) = returnMM (bindings, atom)
- do_arg bindings atom@(StgVarAtom old_var)
+ do_arg bindings atom@(StgVarArg old_var)
= let
- var_type = getIdUniType old_var
+ var_type = idType old_var
in
if not (is_fun_type var_type) then
returnMM (bindings, atom) -- easy
let
new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc
in
- returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
+ returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
where
is_fun_type ty = isFunType (getTauType ty)
---------------
- mk_stg_let :: CostCentre -> (Id, Id) -> PlainStgExpr -> PlainStgExpr
+ mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr
mk_stg_let cc (new_var, old_var) body
= let
- rhs_body = StgApp (StgVarAtom old_var) [{-no args-}] bOGUS_LVs
+ rhs_body = StgApp (StgVarArg old_var) [{-no args-}] bOGUS_LVs
rhs = StgRhsClosure cc
stgArgOcc -- safe...
[{-junk-}] Updatable [{-no args-}] rhs_body
- in
+ in
StgLet (StgNonRec new_var rhs) body
where
bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
-> CostCentre -- prevailing CostCentre
-- if none, subsumedCosts at top-level
-- useCurrentCostCentre at nested levels
- -> SplitUniqSupply
+ -> UniqSupply
-> CollectedCCs
-> (CollectedCCs, result)
-- the initUs function also returns the final UniqueSupply and CollectedCCs
initMM :: FAST_STRING -- module name, which we may consult
- -> SplitUniqSupply
+ -> UniqSupply
-> MassageM a
-> (CollectedCCs, a)
returnMM (b3, r:rs)
getUniqueMM :: MassageM Unique
-getUniqueMM mod scope_cc us ccs = (ccs, getSUnique us)
+getUniqueMM mod scope_cc us ccs = (ccs, getUnique us)
\end{code}
\begin{code}
cc_to_use
= if not (noCostCentreAttached cc_to_try
|| currentOrSubsumedCosts cc_to_try) then
- cc_to_try
+ cc_to_try
else
uncalved_scope_cc
-- carry on as before, but be sure it
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrefixSyn where
-import HsBinds(Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsExpr(Expr)
-import HsImpExp(IfaceImportDecl)
-import HsPat(InPat)
-import HsPragmas(ClassOpPragmas, GenPragmas)
-import HsTypes(PolyType)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-import SrcLoc(SrcLoc)
-data RdrBinding = RdrNullBind | RdrAndBindings RdrBinding RdrBinding | RdrTyData (TyDecl ProtoName) | RdrTySynonym (TyDecl ProtoName) | RdrFunctionBinding Int [RdrMatch] | RdrPatternBinding Int [RdrMatch] | RdrClassDecl (ClassDecl ProtoName (InPat ProtoName)) | RdrInstDecl (_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)) | RdrDefaultDecl (DefaultDecl ProtoName) | RdrIfaceImportDecl IfaceImportDecl | RdrTySig [ProtoName] (PolyType ProtoName) RdrTySigPragmas SrcLoc | RdrSpecValSig [Sig ProtoName] | RdrInlineValSig (Sig ProtoName) | RdrDeforestSig (Sig ProtoName) | RdrMagicUnfoldingSig (Sig ProtoName) | RdrSpecInstSig (SpecialisedInstanceSig ProtoName) | RdrAbstractTypeSig (DataTypeSig ProtoName) | RdrSpecDataSig (DataTypeSig ProtoName)
-type RdrId = ProtoName
-data RdrMatch = RdrMatch Int _PackedString (InPat ProtoName) [(Expr ProtoName (InPat ProtoName), Expr ProtoName (InPat ProtoName))] RdrBinding
-data RdrTySigPragmas = RdrNoPragma | RdrGenPragmas (GenPragmas ProtoName) | RdrClassOpPragmas (ClassOpPragmas ProtoName)
-type SigConverter = RdrBinding -> [Sig ProtoName]
-type SrcFile = _PackedString
-type SrcFun = _PackedString
-type SrcLine = Int
-readInteger :: [Char] -> Integer
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[PrefixSyn]{``Prefix-form'' syntax}
readInteger
) where
-import AbsSyn
-import ProtoName ( ProtoName(..) ) -- .. is for pragmas only
-import Outputable
-import Util -- pragmas only
+import Ubiq{-uitous-}
+
+import HsSyn
+import RdrHsSyn
+import Util ( panic )
type RdrId = ProtoName
type SrcLine = Int
type SrcFile = FAST_STRING
-type SrcFun = FAST_STRING
+type SrcFun = ProtoName
\end{code}
\begin{code}
= RdrNullBind
| RdrAndBindings RdrBinding RdrBinding
- | RdrTyData ProtoNameTyDecl
- | RdrTySynonym ProtoNameTyDecl
+ | RdrTyDecl ProtoNameTyDecl
| RdrFunctionBinding SrcLine [RdrMatch]
| RdrPatternBinding SrcLine [RdrMatch]
| RdrClassDecl ProtoNameClassDecl
- | RdrInstDecl ( FAST_STRING{-original module's name-} ->
- FAST_STRING{-informant module's name-} ->
- Bool{-from here?-} ->
- ProtoNameInstDecl )
+ | RdrInstDecl ProtoNameInstDecl
| RdrDefaultDecl ProtoNameDefaultDecl
- | RdrIfaceImportDecl IfaceImportDecl
+ | RdrIfaceImportDecl (IfaceImportDecl ProtoName)
+ | RdrIfaceFixities [ProtoNameFixityDecl]
-- signatures are mysterious; we can't
-- tell if its a Sig or a ClassOpSig,
| RdrInlineValSig ProtoNameSig
| RdrDeforestSig ProtoNameSig
| RdrMagicUnfoldingSig ProtoNameSig
- | RdrSpecInstSig ProtoNameSpecialisedInstanceSig
- | RdrAbstractTypeSig ProtoNameDataTypeSig
- | RdrSpecDataSig ProtoNameDataTypeSig
+ | RdrSpecInstSig ProtoNameSpecInstSig
+ | RdrSpecDataSig ProtoNameSpecDataSig
data RdrTySigPragmas
= RdrNoPragma
\begin{code}
data RdrMatch
- = RdrMatch SrcLine SrcFun ProtoNamePat [(ProtoNameExpr, ProtoNameExpr)] RdrBinding
- -- (guard, expr)
+ = RdrMatch_NoGuard
+ SrcLine SrcFun
+ ProtoNamePat
+ ProtoNameHsExpr
+ RdrBinding
+
+ | RdrMatch_Guards
+ SrcLine SrcFun
+ ProtoNamePat
+ [(ProtoNameHsExpr, ProtoNameHsExpr)]
+ -- (guard, expr)
+ RdrBinding
\end{code}
Unscramble strings representing oct/dec/hex integer literals:
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface PrefixToHs where
-import HsBinds(Binds, MonoBinds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IfaceImportDecl)
-import HsMatches(Match)
-import HsPat(InPat)
-import PrefixSyn(RdrBinding, RdrMatch)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-cvBinds :: _PackedString -> (RdrBinding -> [Sig ProtoName]) -> RdrBinding -> Binds ProtoName (InPat ProtoName)
-cvClassOpSig :: RdrBinding -> [Sig ProtoName]
-cvInstDeclSig :: RdrBinding -> [Sig ProtoName]
-cvInstDecls :: Bool -> _PackedString -> _PackedString -> [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)] -> [InstDecl ProtoName (InPat ProtoName)]
-cvMatches :: _PackedString -> Bool -> [RdrMatch] -> [Match ProtoName (InPat ProtoName)]
-cvMonoBinds :: _PackedString -> [RdrBinding] -> MonoBinds ProtoName (InPat ProtoName)
-cvSepdBinds :: _PackedString -> (RdrBinding -> [Sig ProtoName]) -> [RdrBinding] -> Binds ProtoName (InPat ProtoName)
-cvValSig :: RdrBinding -> [Sig ProtoName]
-sepDeclsForInterface :: RdrBinding -> ([TyDecl ProtoName], [ClassDecl ProtoName (InPat ProtoName)], [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)], [RdrBinding], [IfaceImportDecl])
-sepDeclsForTopBinds :: RdrBinding -> ([TyDecl ProtoName], [DataTypeSig ProtoName], [ClassDecl ProtoName (InPat ProtoName)], [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)], [SpecialisedInstanceSig ProtoName], [DefaultDecl ProtoName], [RdrBinding])
-sepDeclsIntoSigsAndBinds :: RdrBinding -> ([RdrBinding], [RdrBinding])
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[PrefixToHS]{Support routines for converting ``prefix form'' to Haskell abstract syntax}
cvBinds,
cvClassOpSig,
cvInstDeclSig,
- cvInstDecls,
cvMatches,
cvMonoBinds,
cvSepdBinds,
sepDeclsIntoSigsAndBinds
) where
-IMPORT_Trace -- ToDo: rm
-import Pretty
+import Ubiq{-uitous-}
-import AbsSyn
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import Outputable
-import PrefixSyn
-import ProtoName -- ProtoName(..), etc.
+import PrefixSyn -- and various syntaxen.
+import HsSyn
+import RdrHsSyn
+import HsPragmas ( noGenPragmas, noClassOpPragmas )
+
+import ProtoName ( ProtoName(..) )
import SrcLoc ( mkSrcLoc2 )
-import Util
+import Util ( panic, assertPanic )
\end{code}
%************************************************************************
%* *
%************************************************************************
-\begin{code}
-cvInstDecls :: Bool -> FAST_STRING -> FAST_STRING
- -> [FAST_STRING -> FAST_STRING -> Bool -> ProtoNameInstDecl] -- incomplete InstDecls
- -> [ProtoNameInstDecl]
-
-cvInstDecls from_here orig_modname informant_modname decls
- = [ decl_almost orig_modname informant_modname from_here
- | decl_almost <- decls ]
-\end{code}
-
We make a point not to throw any user-pragma ``sigs'' at
these conversion functions:
\begin{code}
cvValSig (RdrTySig vars poly_ty pragmas src_loc)
= [ Sig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ]
where
- cvt_pragmas RdrNoPragma = NoGenPragmas
+ cvt_pragmas RdrNoPragma = noGenPragmas
cvt_pragmas (RdrGenPragmas ps) = ps
cvClassOpSig (RdrTySig vars poly_ty pragmas src_loc)
= [ ClassOpSig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ]
where
- cvt_pragmas RdrNoPragma = NoClassOpPragmas
+ cvt_pragmas RdrNoPragma = noClassOpPragmas
cvt_pragmas (RdrClassOpPragmas ps) = ps
cvInstDeclSig (RdrSpecValSig sigs) = sigs
%************************************************************************
%* *
-\subsection[cvBinds-etc]{Converting to @Binds@, @MonoBinds@, etc.}
+\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
%* *
%************************************************************************
analyser.
\begin{code}
-cvBinds :: SrcFile -> SigConverter -> RdrBinding -> ProtoNameBinds
+cvBinds :: SrcFile -> SigConverter -> RdrBinding -> ProtoNameHsBinds
cvBinds sf sig_cvtr raw_binding
= cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding)
-cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> ProtoNameBinds
+cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> ProtoNameHsBinds
cvSepdBinds sf sig_cvtr bindings
= case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) ->
if (null sigs)
mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
mangle_bind (b_acc, s_acc)
- (RdrPatternBinding lousy_srcline [patbinding@(RdrMatch good_srcline _ _ _ _)])
+ (RdrPatternBinding lousy_srcline [patbinding])
-- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
= case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
let
(b_acc `AndMonoBinds`
PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
}
+ where
+ good_srcline = case patbinding of
+ RdrMatch_NoGuard ln _ _ _ _ -> ln
+ RdrMatch_Guards ln _ _ _ _ -> ln
+
mangle_bind _ (RdrPatternBinding _ _)
= panic "mangleBinding: more than one pattern on a RdrPatternBinding"
\end{code}
\begin{code}
-cvPatMonoBind :: SrcFile -> RdrMatch -> (ProtoNamePat, [ProtoNameGRHS], ProtoNameBinds)
+cvPatMonoBind :: SrcFile -> RdrMatch -> (ProtoNamePat, [ProtoNameGRHS], ProtoNameHsBinds)
-cvPatMonoBind sf (RdrMatch srcline srcfun pat guardedexprs binding)
- = (pat, cvGRHSs srcfun sf srcline guardedexprs, cvBinds sf cvValSig binding)
+cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
+ = (pat, [OtherwiseGRHS expr (mkSrcLoc2 sf srcline)], cvBinds sf cvValSig binding)
+
+cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
+ = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
cvFunMonoBind :: SrcFile -> [RdrMatch] -> (ProtoName {-VarName-}, [ProtoNameMatch])
-cvFunMonoBind sf matches@((RdrMatch srcline srcfun pat guardedexprs binding):_)
- = ( Unk srcfun, -- cheating ...
- cvMatches sf False matches )
+cvFunMonoBind sf matches
+ = (srcfun {- cheating ... -}, cvMatches sf False matches)
+ where
+ srcfun = case (head matches) of
+ RdrMatch_NoGuard _ sfun _ _ _ -> sfun
+ RdrMatch_Guards _ sfun _ _ _ -> sfun
cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [ProtoNameMatch]
cvMatch :: SrcFile -> Bool -> RdrMatch -> ProtoNameMatch
cvMatches sf is_case matches = map (cvMatch sf is_case) matches
-cvMatch sf is_case (RdrMatch srcline srcfun pat guardedexprs binding)
+cvMatch sf is_case rdr_match
= foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn (cvGRHSs srcfun sf srcline guardedexprs)
- (cvBinds sf cvValSig binding)))
+ (GRHSMatch (GRHSsAndBindsIn guarded_exprs (cvBinds sf cvValSig binding)))
-- For a FunMonoBinds, the first flattened "pattern" is
-- just the function name, and we don't want to keep it.
-- For a case expr, it's (presumably) a constructor name -- and
-- we most certainly want to keep it! Hence the monkey busines...
--- (trace ("cvMatch:"++(ppShow 80 (ppr PprDebug pat))) (
(if is_case then -- just one pattern: leave it untouched...
[pat']
else
case pat' of
ConPatIn _ pats -> pats
)
--- ))
where
+ (pat, binding, guarded_exprs)
+ = case rdr_match of
+ RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)])
+ RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
+
+ ---------------------
pat' = doctor_pat pat
-- a ConOpPatIn in the corner may be handled by converting it to
doctor_pat (ConOpPatIn p1 op p2) = ConPatIn op [p1, p2]
doctor_pat other_pat = other_pat
-cvGRHSs :: FAST_STRING -> SrcFile -> SrcLine -> [(ProtoNameExpr, ProtoNameExpr)] -> [ProtoNameGRHS]
-
-cvGRHSs sfun sf sl guarded_exprs = map (cvGRHS sfun sf sl) guarded_exprs
-
-cvGRHS :: FAST_STRING -> SrcFile -> SrcLine -> (ProtoNameExpr, ProtoNameExpr) -> ProtoNameGRHS
-
-cvGRHS sfun sf sl (Var v@(Unk str), e)
- | str == SLIT("__o") -- "__otherwise" ToDo: de-urgh-ify
- = OtherwiseGRHS e (mkSrcLoc2 sf sl)
+cvGRHS :: SrcFile -> SrcLine -> (ProtoNameHsExpr, ProtoNameHsExpr) -> ProtoNameGRHS
-cvGRHS sfun sf sl (g, e)
- = GRHS g e (mkSrcLoc2 sf sl)
+cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl)
\end{code}
%************************************************************************
Separate declarations into all the various kinds:
\begin{display}
-tys RdrTyData RdrTySynonym
-type "sigs" RdrAbstractTypeSig RdrSpecDataSig
+tys RdrTyDecl
+ty "sigs" RdrSpecDataSig
classes RdrClassDecl
-instances RdrInstDecl
-instance "sigs" RdrSpecInstSig
+insts RdrInstDecl
+inst "sigs" RdrSpecInstSig
defaults RdrDefaultDecl
binds RdrFunctionBinding RdrPatternBinding RdrTySig
RdrSpecValSig RdrInlineValSig RdrDeforestSig
(Those functions follow...)
\begin{code}
-sepDecls (RdrTyData a)
- tys tysigs classes insts instsigs defaults binds iimps
- = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps)
-
-sepDecls (RdrTySynonym a)
- tys tysigs classes insts instsigs defaults binds iimps
- = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps)
+sepDecls (RdrTyDecl a)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs)
sepDecls a@(RdrFunctionBinding _ _)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
sepDecls a@(RdrPatternBinding _ _)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
-- RdrAndBindings catered for below...
sepDecls (RdrClassDecl a)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,a:classes,insts,instsigs,defaults,binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,a:classes,insts,instsigs,defaults,binds,iimps,ifixs)
sepDecls (RdrInstDecl a)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,a:insts,instsigs,defaults,binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,a:insts,instsigs,defaults,binds,iimps,ifixs)
sepDecls (RdrDefaultDecl a)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,a:defaults,binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,a:defaults,binds,iimps,ifixs)
sepDecls a@(RdrTySig _ _ _ _)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
sepDecls (RdrIfaceImportDecl a)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,binds,a:iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,binds,a:iimps,ifixs)
+
+sepDecls (RdrIfaceFixities a)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,a++ifixs)
sepDecls a@(RdrSpecValSig _)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
sepDecls a@(RdrInlineValSig _)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
sepDecls a@(RdrDeforestSig _)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
sepDecls a@(RdrMagicUnfoldingSig _)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
sepDecls (RdrSpecInstSig a)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,a:instsigs,defaults,binds,iimps)
-
-sepDecls (RdrAbstractTypeSig a)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,a:instsigs,defaults,binds,iimps,ifixs)
sepDecls (RdrSpecDataSig a)
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs)
sepDecls RdrNullBind
- tys tysigs classes insts instsigs defaults binds iimps
- = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps)
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs)
sepDecls (RdrAndBindings bs1 bs2)
- tys tysigs classes insts instsigs defaults binds iimps
- = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds iimps) of {
- (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) ->
- sepDecls bs1 tys tysigs classes insts instsigs defaults binds iimps
+ tys tysigs classes insts instsigs defaults binds iimps ifixs
+ = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds iimps ifixs) of {
+ (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) ->
+ sepDecls bs1 tys tysigs classes insts instsigs defaults binds iimps ifixs
}
\end{code}
\begin{code}
sepDeclsForTopBinds binding
- = case (sepDecls binding [] [] [] [] [] [] [] [])
- of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) ->
- ASSERT (null iimps)
+ = case (sepDecls binding [] [] [] [] [] [] [] [] [])
+ of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) ->
+ ASSERT ((null iimps)
+ && (null ifixs))
(tys,tysigs,classes,insts,instsigs,defaults,binds)
}
sepDeclsForBinds binding
- = case (sepDecls binding [] [] [] [] [] [] [] [])
- of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) ->
+ = case (sepDecls binding [] [] [] [] [] [] [] [] [])
+ of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) ->
ASSERT ((null tys)
&& (null tysigs)
&& (null classes)
&& (null insts)
&& (null instsigs)
&& (null defaults)
- && (null iimps))
+ && (null iimps)
+ && (null ifixs))
binds
}
sepDeclsForInterface binding
- = case (sepDecls binding [] [] [] [] [] [] [] [])
- of { (tys,tysigs,classes,insts,instsigs,defaults,sigs,iimps) ->
+ = case (sepDecls binding [] [] [] [] [] [] [] [] [])
+ of { (tys,tysigs,classes,insts,instsigs,defaults,sigs,iimps,ifixs) ->
ASSERT ((null defaults)
&& (null tysigs)
&& (null instsigs))
ASSERT (not (not_all_sigs sigs))
- (tys,classes,insts,sigs,iimps)
+ (tys,classes,insts,sigs,iimps,ifixs)
}
where
not_all_sigs sigs = not (all is_a_sig sigs)
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
+
+(Well, really, for specialisations involving @ProtoName@s, even if
+they are used somewhat later on in the compiler...)
+
+\begin{code}
+#include "HsVersions.h"
+
+module RdrHsSyn (
+ cmpInstanceTypes,
+ eqMonoType,
+ getMentionedVars,
+ getNonPrelOuterTyCon,
+ ExportListInfo(..),
+ getImportees,
+ getExportees,
+ getRawImportees,
+ getRawExportees,
+
+ ProtoNameArithSeqInfo(..),
+ ProtoNameBind(..),
+ ProtoNameClassDecl(..),
+ ProtoNameClassOpPragmas(..),
+ ProtoNameClassOpSig(..),
+ ProtoNameClassPragmas(..),
+ ProtoNameConDecl(..),
+ ProtoNameContext(..),
+ ProtoNameCoreExpr(..),
+ ProtoNameDataPragmas(..),
+ ProtoNameSpecDataSig(..),
+ ProtoNameDefaultDecl(..),
+ ProtoNameFixityDecl(..),
+ ProtoNameGRHS(..),
+ ProtoNameGRHSsAndBinds(..),
+ ProtoNameGenPragmas(..),
+ ProtoNameHsBinds(..),
+ ProtoNameHsExpr(..),
+ ProtoNameHsModule(..),
+ ProtoNameIE(..),
+ ProtoNameImportedInterface(..),
+ ProtoNameInstDecl(..),
+ ProtoNameInstancePragmas(..),
+ ProtoNameInterface(..),
+ ProtoNameMatch(..),
+ ProtoNameMonoBinds(..),
+ ProtoNameMonoType(..),
+ ProtoNamePat(..),
+ ProtoNamePolyType(..),
+ ProtoNameQual(..),
+ ProtoNameSig(..),
+ ProtoNameSpecInstSig(..),
+ ProtoNameStmt(..),
+ ProtoNameTyDecl(..),
+ ProtoNameUnfoldingCoreExpr(..)
+ ) where
+
+import Ubiq{-uitous-}
+
+import Bag ( emptyBag, snocBag, unionBags, listToBag, Bag )
+import FiniteMap ( mkSet, listToFM, emptySet, emptyFM, FiniteSet(..), FiniteMap )
+import HsSyn
+import Outputable ( ExportFlag(..) )
+import ProtoName ( cmpProtoName, ProtoName(..) )
+import Util ( panic{-ToDo:rm eventually-} )
+\end{code}
+
+\begin{code}
+type ProtoNameArithSeqInfo = ArithSeqInfo Fake Fake ProtoName ProtoNamePat
+type ProtoNameBind = Bind Fake Fake ProtoName ProtoNamePat
+type ProtoNameClassDecl = ClassDecl Fake Fake ProtoName ProtoNamePat
+type ProtoNameClassOpPragmas = ClassOpPragmas ProtoName
+type ProtoNameClassOpSig = Sig ProtoName
+type ProtoNameClassPragmas = ClassPragmas ProtoName
+type ProtoNameConDecl = ConDecl ProtoName
+type ProtoNameContext = Context ProtoName
+type ProtoNameCoreExpr = UnfoldingCoreExpr ProtoName
+type ProtoNameDataPragmas = DataPragmas ProtoName
+type ProtoNameSpecDataSig = SpecDataSig ProtoName
+type ProtoNameDefaultDecl = DefaultDecl ProtoName
+type ProtoNameFixityDecl = FixityDecl ProtoName
+type ProtoNameGRHS = GRHS Fake Fake ProtoName ProtoNamePat
+type ProtoNameGRHSsAndBinds = GRHSsAndBinds Fake Fake ProtoName ProtoNamePat
+type ProtoNameGenPragmas = GenPragmas ProtoName
+type ProtoNameHsBinds = HsBinds Fake Fake ProtoName ProtoNamePat
+type ProtoNameHsExpr = HsExpr Fake Fake ProtoName ProtoNamePat
+type ProtoNameHsModule = HsModule Fake Fake ProtoName ProtoNamePat
+type ProtoNameIE = IE ProtoName
+type ProtoNameImportedInterface = ImportedInterface Fake Fake ProtoName ProtoNamePat
+type ProtoNameInstDecl = InstDecl Fake Fake ProtoName ProtoNamePat
+type ProtoNameInstancePragmas = InstancePragmas ProtoName
+type ProtoNameInterface = Interface Fake Fake ProtoName ProtoNamePat
+type ProtoNameMatch = Match Fake Fake ProtoName ProtoNamePat
+type ProtoNameMonoBinds = MonoBinds Fake Fake ProtoName ProtoNamePat
+type ProtoNameMonoType = MonoType ProtoName
+type ProtoNamePat = InPat ProtoName
+type ProtoNamePolyType = PolyType ProtoName
+type ProtoNameQual = Qual Fake Fake ProtoName ProtoNamePat
+type ProtoNameSig = Sig ProtoName
+type ProtoNameSpecInstSig = SpecInstSig ProtoName
+type ProtoNameStmt = Stmt Fake Fake ProtoName ProtoNamePat
+type ProtoNameTyDecl = TyDecl ProtoName
+type ProtoNameUnfoldingCoreExpr = UnfoldingCoreExpr ProtoName
+\end{code}
+
+\begin{code}
+eqMonoType :: ProtoNameMonoType -> ProtoNameMonoType -> Bool
+
+eqMonoType a b = case (cmpMonoType cmpProtoName a b) of { EQ_ -> True; _ -> False }
+\end{code}
+
+
+@cmpInstanceTypes@ compares two @PolyType@s which are being used as
+``instance types.'' This is used when comparing as-yet-unrenamed
+instance decls to eliminate duplicates. We allow things (e.g.,
+overlapping instances) which standard Haskell doesn't, so we must
+cater for that. Generally speaking, the instance-type
+``shape''-checker in @tcInstDecl@ will catch any mischief later on.
+
+All we do is call @cmpMonoType@, passing it a tyvar-comparing function
+that always claims that tyvars are ``equal;'' the result is that we
+end up comparing the non-tyvar-ish structure of the two types.
+
+\begin{code}
+cmpInstanceTypes :: ProtoNamePolyType -> ProtoNamePolyType -> TAG_
+
+cmpInstanceTypes (HsPreForAllTy _ ty1) (HsPreForAllTy _ ty2)
+ = cmpMonoType funny_cmp ty1 ty2 -- Hey! ignore those contexts!
+ where
+ funny_cmp :: ProtoName -> ProtoName -> TAG_
+
+ {- The only case we are really trying to catch
+ is when both types are tyvars: which are both
+ "Unk"s and names that start w/ a lower-case letter! (Whew.)
+ -}
+ funny_cmp (Unk u1) (Unk u2)
+ | isLower s1 && isLower s2 = EQ_
+ where
+ s1 = _HEAD_ u1
+ s2 = _HEAD_ u2
+
+ funny_cmp x y = cmpProtoName x y -- otherwise completely normal
+\end{code}
+
+@getNonPrelOuterTyCon@ is a yukky function required when deciding
+whether to import an instance decl. If the class name or type
+constructor are ``wanted'' then we should import it, otherwise not.
+But the built-in core constructors for lists, tuples and arrows are
+never ``wanted'' in this sense. @getNonPrelOuterTyCon@ catches just a
+user-defined tycon and returns it.
+
+\begin{code}
+getNonPrelOuterTyCon :: ProtoNameMonoType -> Maybe ProtoName
+
+getNonPrelOuterTyCon (MonoTyApp con _) = Just con
+getNonPrelOuterTyCon _ = Nothing
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Grabbing importees and exportees}
+%* *
+%************************************************************************
+
+We want to know what names are exported (the first list of the result)
+and what modules are exported (the second list of the result).
+\begin{code}
+type ExportListInfo
+ = Maybe -- Nothing => no export list
+ ( FiniteMap FAST_STRING ExportFlag,
+ -- Assoc list of im/exported things &
+ -- their "export" flags (im/exported
+ -- abstractly, concretely, etc.)
+ -- Hmm... slight misnomer there (WDP 95/02)
+ FiniteSet FAST_STRING )
+ -- List of modules to be exported
+ -- entirely; NB: *not* everything with
+ -- original names in these modules;
+ -- but: everything that these modules'
+ -- interfaces told us about.
+ -- Note: This latter component can
+ -- only arise on export lists.
+
+getImportees :: [ProtoNameIE] -> FiniteSet FAST_STRING
+getExportees :: Maybe [ProtoNameIE] -> ExportListInfo
+
+getRawImportees :: [ProtoNameIE] -> [FAST_STRING]
+getRawExportees :: Maybe [ProtoNameIE] -> ([(ProtoName, ExportFlag)], [FAST_STRING])
+ -- "Raw" gives the raw lists of things; we need this for
+ -- checking for duplicates.
+
+getImportees [] = emptySet
+getImportees imps = mkSet (getRawImportees imps)
+
+getExportees Nothing = Nothing
+getExportees exps
+ = case (getRawExportees exps) of { (pairs, mods) ->
+ Just (panic "RdrHsSyn.getExportees" {-listToFM pairs-}, mkSet mods) }
+
+getRawImportees imps
+ = foldr do_imp [] imps
+ where
+ do_imp (IEVar (Unk n)) acc = n:acc
+ do_imp (IEThingAbs (Unk n)) acc = n:acc
+ do_imp (IEThingAll (Unk n)) acc = n:acc
+
+getRawExportees Nothing = ([], [])
+getRawExportees (Just exps)
+ = foldr do_exp ([],[]) exps
+ where
+ do_exp (IEVar n) (prs, mods) = ((n, ExportAll):prs, mods)
+ do_exp (IEThingAbs n) (prs, mods) = ((n, ExportAbs):prs, mods)
+ do_exp (IEThingAll n) (prs, mods) = ((n, ExportAll):prs, mods)
+ do_exp (IEModuleContents n) (prs, mods) = (prs, n : mods)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Collect mentioned variables}
+%* *
+%************************************************************************
+
+This is just a {\em hack} whichs collects, from a module body, all the
+variables that are ``mentioned,'' either as top-level binders or as
+free variables. We can then use this list when walking over
+interfaces, using it to avoid imported variables that are patently of
+no interest.
+
+We have to be careful to look out for \tr{M..} constructs in the
+export list; if so, the game is up (and we must so report).
+
+\begin{code}
+type NameMapper a = FAST_STRING -> Maybe a
+ -- For our purposes here, we don't care *what*
+ -- they are mapped to; only if the names are
+ -- in the mapper
+
+getMentionedVars :: NameMapper any -- a prelude-name lookup function, so
+ -- we can avoid recording prelude things
+ -- as "mentioned"
+ -> Maybe [IE ProtoName]{-exports-} -- All the bits of the module body to
+ -> [ProtoNameFixityDecl]-- look in for "mentioned" vars.
+ -> [ProtoNameClassDecl]
+ -> [ProtoNameInstDecl]
+ -> ProtoNameHsBinds
+
+ -> (Bool, -- True <=> M.. construct in exports
+ Bag FAST_STRING) -- list of vars "mentioned" in the module body
+
+getMentionedVars val_nf exports fixes class_decls inst_decls binds
+ = panic "getMentionedVars (RdrHsSyn)"
+{- TO THE END
+ = case (mention_IE exports) of { (module_dotdot_seen, export_mentioned) ->
+ (module_dotdot_seen,
+ initMentioned val_nf export_mentioned (
+-- mapMent fixity fixes `thenMent_` -- see note below.
+ mapMent classDecl class_decls `thenMent_`
+ mapMent instDecl inst_decls `thenMent_`
+ bindsDecls True{-top-level-} binds )
+ )}
+\end{code}
+ToDo: if we ever do something proper with fixity declarations,
+we will need to create a @fixities@ function and make it do something.
+
+Here's relevant bit of monad fluff: hides carrying around
+the NameMapper function (down only) and passing along an
+accumulator:
+\begin{code}
+type MentionM nm a = NameMapper nm -> Bag FAST_STRING -> Bag FAST_STRING
+
+initMentioned :: NameMapper nm -> Bag FAST_STRING -> MentionM nm a -> Bag FAST_STRING
+thenMent_ :: MentionM nm a -> MentionM nm b -> MentionM nm b
+returnNothing :: MentionM nm a
+mapMent :: (a -> MentionM nm b) -> [a] -> MentionM nm b
+mentionedName :: FAST_STRING -> MentionM nm a
+mentionedNames :: [FAST_STRING] -> MentionM nm a
+lookupAndAdd :: ProtoName -> MentionM nm a
+
+initMentioned val_nf acc action = action val_nf acc
+
+returnNothing val_nf acc = acc
+
+thenMent_ act1 act2 val_nf acc
+ = act2 val_nf (act1 val_nf acc)
+
+mapMent f [] = returnNothing
+mapMent f (x:xs)
+ = f x `thenMent_`
+ mapMent f xs
+
+mentionedName name val_nf acc
+ = acc `snocBag` name
+
+mentionedNames names val_nf acc
+ = acc `unionBags` listToBag names
+
+lookupAndAdd (Unk str) val_nf acc
+ | _LENGTH_ str >= 3 -- simply don't bother w/ very short names...
+ = case (val_nf str) of
+ Nothing -> acc `snocBag` str
+ Just _ -> acc
+
+lookupAndAdd _ _ acc = acc -- carry on with what we had
+\end{code}
+
+\begin{code}
+mention_IE :: [IE ProtoName] -> (Bool, Bag FAST_STRING)
+
+mention_IE exps
+ = foldr men (False, emptyBag) exps
+ where
+ men (IEVar str) (dotdot_seen, so_far) = (dotdot_seen, so_far `snocBag` str)
+ men (IEModuleContents _) (_, so_far) = (True, so_far)
+ men other_ie acc = acc
+\end{code}
+
+\begin{code}
+classDecl (ClassDecl _ _ _ _ binds _ _) = monoBinds True{-toplev-} binds
+instDecl (InstDecl _ _ binds _ _ _ _ _) = monoBinds True{-toplev-} binds
+\end{code}
+
+\begin{code}
+bindsDecls toplev EmptyBinds = returnNothing
+bindsDecls toplev (ThenBinds a b)= bindsDecls toplev a `thenMent_` bindsDecls toplev b
+bindsDecls toplev (SingleBind a) = bindDecls toplev a
+bindsDecls toplev (BindWith a _) = bindDecls toplev a
+
+bindDecls toplev EmptyBind = returnNothing
+bindDecls toplev (NonRecBind a) = monoBinds toplev a
+bindDecls toplev (RecBind a) = monoBinds toplev a
+
+monoBinds toplev EmptyMonoBinds = returnNothing
+monoBinds toplev (AndMonoBinds a b) = monoBinds toplev a `thenMent_` monoBinds toplev b
+monoBinds toplev (PatMonoBind p gb _)
+ = (if toplev
+ then mentionedNames (map stringify (collectPatBinders p))
+ else returnNothing) `thenMent_`
+ grhssAndBinds gb
+
+monoBinds toplev (FunMonoBind v ms _)
+ = (if toplev
+ then mentionedName (stringify v)
+ else returnNothing) `thenMent_`
+ mapMent match ms
+
+stringify :: ProtoName -> FAST_STRING
+stringify (Unk s) = s
+\end{code}
+
+\begin{code}
+match (PatMatch _ m) = match m
+match (GRHSMatch gb) = grhssAndBinds gb
+
+grhssAndBinds (GRHSsAndBindsIn gs bs)
+ = mapMent grhs gs `thenMent_` bindsDecls False bs
+
+grhs (OtherwiseGRHS e _) = expr e
+grhs (GRHS g e _) = expr g `thenMent_` expr e
+\end{code}
+
+\begin{code}
+expr (HsVar v) = lookupAndAdd v
+
+expr (HsLit _) = returnNothing
+expr (HsLam m) = match m
+expr (HsApp a b) = expr a `thenMent_` expr b
+expr (OpApp a b c) = expr a `thenMent_` expr b `thenMent_` expr c
+expr (SectionL a b) = expr a `thenMent_` expr b
+expr (SectionR a b) = expr a `thenMent_` expr b
+expr (CCall _ es _ _ _) = mapMent expr es
+expr (HsSCC _ e) = expr e
+expr (HsCase e ms _)= expr e `thenMent_` mapMent match ms
+expr (HsLet b e) = expr e `thenMent_` bindsDecls False{-not toplev-} b
+expr (HsDo bs _) = panic "mentioned_whatnot:RdrHsSyn:HsDo"
+expr (ListComp e q) = expr e `thenMent_` mapMent qual q
+expr (ExplicitList es) = mapMent expr es
+expr (ExplicitTuple es) = mapMent expr es
+expr (RecordCon con rbinds) = panic "mentioned:RdrHsSyn:RecordCon"
+expr (RecordUpd aexp rbinds) = panic "mentioned:RdrHsSyn:RecordUpd"
+expr (ExprWithTySig e _) = expr e
+expr (HsIf b t e _) = expr b `thenMent_` expr t `thenMent_` expr e
+expr (ArithSeqIn s) = arithSeq s
+
+arithSeq (From a) = expr a
+arithSeq (FromThen a b) = expr a `thenMent_` expr b
+arithSeq (FromTo a b) = expr a `thenMent_` expr b
+arithSeq (FromThenTo a b c) = expr a `thenMent_` expr b `thenMent_` expr c
+
+qual (GeneratorQual _ e) = expr e
+qual (FilterQual e) = expr e
+qual (LetQual bs) = bindsDecls False{-not toplev-} bs
+-}
+\end{code}
--- /dev/null
+This module breaks the loops among the reader modules
+ReadPragmas and ReadPrefix.
+
+\begin{code}
+interface RdrLoop where
+
+import PreludeStdIO ( Maybe )
+
+import U_list ( U_list )
+import U_maybe ( U_maybe )
+import U_ttype ( U_ttype )
+import UgenUtil ( UgnM(..), ParseTree(..) )
+import ReadPrefix ( rdConDecl, rdMonoType, wlkList, wlkMaybe, wlkMonoType )
+import RdrHsSyn ( ProtoNameMonoType(..), ProtoNameConDecl(..) )
+
+data U_list
+data U_ttype
+
+rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
+rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
+wlkList :: (_Addr -> UgnM a) -> U_list -> UgnM [a]
+wlkMaybe :: (_Addr -> UgnM a) -> U_maybe -> UgnM (Maybe a)
+wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
+\end{code}
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface ReadPragmas where
-import BasicLit(BasicLit)
-import HsCore(UfId, UnfoldingCoreAtom, UnfoldingCoreExpr)
-import HsPragmas(ClassPragmas, DataPragmas, GenPragmas, InstancePragmas, TypePragmas)
-import HsTypes(MonoType, PolyType)
-import LiftMonad(LiftM)
-import Maybes(Labda)
-import PrefixSyn(RdrTySigPragmas)
-import ProtoName(ProtoName)
-import SimplEnv(UnfoldingGuidance)
-cvt_IdString :: [Char] -> ProtoName
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdBasicLit :: [Char] -> LiftM (BasicLit, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdClassPragma :: [Char] -> LiftM (ClassPragmas ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreAtom :: [Char] -> LiftM (UnfoldingCoreAtom ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreBinder :: [Char] -> LiftM ((ProtoName, PolyType ProtoName), [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreExpr :: [Char] -> LiftM (UnfoldingCoreExpr ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreId :: [Char] -> LiftM (UfId ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdCoreType :: [Char] -> LiftM (PolyType ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdCoreTypeMaybe :: [Char] -> LiftM (Labda (PolyType ProtoName), [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdDataPragma :: [Char] -> LiftM (DataPragmas ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdGenPragma :: [Char] -> LiftM (GenPragmas ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdGuidance :: [Char] -> LiftM (UnfoldingGuidance, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdInstPragma :: [Char] -> LiftM (Labda [Char], InstancePragmas ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdMonoTypeMaybe :: [Char] -> LiftM (Labda (MonoType ProtoName), [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdTySigPragmas :: [Char] -> LiftM (RdrTySigPragmas, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdTypePragma :: [Char] -> LiftM (TypePragmas, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rd_constm :: [Char] -> LiftM ((ProtoName, GenPragmas ProtoName), [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
-\section[ReadPragmas]{Read pragmatic interface info, including Core}
+\section{Read pragmatic interface info, including Core}
\begin{code}
--- HBC does not have stack stubbing; you get a space leak w/
--- default defns from HsVersions.h.
+#include "HsVersions.h"
--- GHC may be overly slow to compile w/ the defaults...
+module ReadPragmas (
+ ProtoUfBinder(..),
-#define BIND {--}
-#define _TO_ `thenLft` ( \ {--}
-#define BEND )
-#define RETN returnLft
-#define RETN_TYPE LiftM
+ wlkClassPragma,
+ wlkDataPragma,
+ wlkInstPragma,
+ wlkTySigPragmas
+ ) where
-#include "HsVersions.h"
-\end{code}
+import Ubiq{-uitous-}
-\begin{code}
-module ReadPragmas where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-
-import AbsPrel ( nilDataCon, readUnfoldingPrimOp, PrimOp(..), PrimKind
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsSyn
-import BasicLit ( mkMachInt, BasicLit(..) )
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
+import RdrLoop -- break dependency loop
+
+import UgenAll -- all Yacc parser gumpff...
+import PrefixSyn -- and various syntaxen.
+import HsSyn
+import RdrHsSyn
+import HsPragmas -- NB: we are concerned with grimy
+import HsCore -- *Pragmas and *Core stuff here
+
+-- others:
+import CoreUnfold ( UnfoldingGuidance(..) )
import Id ( mkTupleCon )
-import IdInfo -- ( UnfoldingGuidance(..) )
-import LiftMonad
-import Maybes ( Maybe(..) )
-import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
-import ReadPrefix ( rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType )
-import Util
+import IdInfo
+import IdUtils ( primOpNameInfo )
+import Literal ( mkMachInt, Literal(..) )
+import Name ( Name(..) )
+import PrelInfo ( nilDataCon )
+import PrimOp ( PrimOp(..), allThePrimOps )
+import PrimRep ( guessPrimRep ) -- really, VERY horrible...
+import ProtoName ( ProtoName(..) )
+import Util ( assertPanic, panic )
\end{code}
+Only used here:
\begin{code}
-rdDataPragma :: String -> RETN_TYPE (ProtoNameDataPragmas, String)
+readUnfoldingPrimOp :: FAST_STRING -> PrimOp
-rdDataPragma ('P' : 'N' : xs) = RETN (DataPragmas [] [], xs)
-
-rdDataPragma ('P' : 'd' : xs)
- = BIND (rdList (rdConDecl srcfile) xs) _TO_ (cons, xs1) ->
- BIND (rdList rd_spec xs1) _TO_ (specs, xs2) ->
- RETN (DataPragmas cons specs, xs2)
- BEND BEND
- where
- srcfile = SLIT("<pragma>")
-
- rd_spec ('P' : '4' : xs)
- = BIND (rdList rdMonoTypeMaybe xs) _TO_ (spec, xs1) ->
- RETN (spec, xs1)
- BEND
+readUnfoldingPrimOp
+ = let
+ -- "reverse" lookup table
+ tbl = map (\ o -> let { (str,_) = primOpNameInfo o } in (str, o)) allThePrimOps
+ in
+ \ str -> case [ op | (s, op) <- tbl, s == str ] of
+ (op:_) -> op
+#ifdef DEBUG
+ [] -> panic "readUnfoldingPrimOp" -- ++ _UNPK_ str ++"::"++show (map fst tbl))
+#endif
\end{code}
\begin{code}
-rdTypePragma :: String -> RETN_TYPE (TypePragmas, String)
+wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
+
+wlkDataPragma pragma
+ = case pragma of
+ U_no_pragma -> returnUgn (DataPragmas [] [])
+ U_idata_pragma cs ss ->
+ wlkList rdConDecl cs `thenUgn` \ cons ->
+ wlkList rd_spec ss `thenUgn` \ specs ->
+ returnUgn (DataPragmas cons specs)
+ where
+ rd_spec pt
+ = rdU_hpragma pt `thenUgn` \ stuff ->
+ case stuff of { U_idata_pragma_4s ss ->
-rdTypePragma ('P' : 'N' : xs) = RETN (NoTypePragmas, xs)
-rdTypePragma ('P' : 't' : xs) = RETN (AbstractTySynonym, xs)
+ wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
+ returnUgn specs }
\end{code}
\begin{code}
-rdClassPragma :: String -> RETN_TYPE (ProtoNameClassPragmas, String)
-
-rdClassPragma ('P' : 'N' : xs) = RETN (NoClassPragmas, xs)
-rdClassPragma ('P' : 'c' : xs)
- = BIND (rdList rdGenPragma xs) _TO_ (gen_pragmas, xs1) ->
- ASSERT(not (null gen_pragmas))
- RETN (SuperDictPragmas gen_pragmas, xs1)
- BEND
+wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
+
+wlkClassPragma pragma
+ = case pragma of
+ U_no_pragma -> returnUgn NoClassPragmas
+ U_iclas_pragma gens ->
+ wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
+ ASSERT(not (null gen_pragmas))
+ returnUgn (SuperDictPragmas gen_pragmas)
\end{code}
\begin{code}
-rdInstPragma :: String -> RETN_TYPE (Maybe FAST_STRING, ProtoNameInstancePragmas, String)
-
-rdInstPragma ('P' : 'N' : xs) = RETN (Nothing, NoInstancePragmas, xs)
-
-rdInstPragma ('P' : 'i' : 's' : xs)
- = BIND (rdIdString xs) _TO_ (modname, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (gen_pragmas, xs2) ->
- RETN (Just modname, SimpleInstancePragma gen_pragmas, xs2)
- BEND BEND
-
-rdInstPragma ('P' : 'i' : 'c' : xs)
- = BIND (rdIdString xs) _TO_ (modname, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (gen_pragma, xs2) ->
- BIND (rdList rd_constm xs2) _TO_ (constm_pragmas, xs3) ->
- RETN (Just modname, ConstantInstancePragma gen_pragma constm_pragmas, xs3)
- BEND BEND BEND
-
-rd_constm ('P' : '1' : xs)
- = BIND (rdId xs) _TO_ (name, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (prag, xs2) ->
- RETN ((name, prag), xs2)
- BEND BEND
+wlkInstPragma :: U_hpragma -> UgnM ProtoNameInstancePragmas
+
+wlkInstPragma pragma
+ = case pragma of
+ U_no_pragma ->
+ returnUgn NoInstancePragmas
+
+ U_iinst_simpl_pragma dfun_gen ->
+ wlkGenPragma dfun_gen `thenUgn` \ gen_pragmas ->
+ returnUgn (SimpleInstancePragma gen_pragmas)
+
+ U_iinst_const_pragma dfun_gen constm_stuff ->
+ wlkGenPragma dfun_gen `thenUgn` \ gen_pragma ->
+ wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
+ returnUgn (ConstantInstancePragma gen_pragma constm_pragmas)
+
+rd_constm pt
+ = rdU_hpragma pt `thenUgn` \ stuff ->
+ case stuff of { U_iname_pragma_pr name gen ->
+
+ wlkGenPragma gen `thenUgn` \ prag ->
+ returnUgn (name, prag) }
\end{code}
\begin{code}
-rdGenPragma :: String -> RETN_TYPE (ProtoNameGenPragmas, String)
-
-rdGenPragma ('P' : 'N' : xs) = RETN (NoGenPragmas, xs)
-
-rdGenPragma ('P': 'g' : xs)
- = BIND (rd_arity xs) _TO_ (arity, xs1) ->
- BIND (rd_update xs1) _TO_ (upd, xs2) ->
- BIND (rd_strict xs2) _TO_ (strict, xs3) ->
- BIND (rd_unfold xs3) _TO_ (unfold, xs4) ->
- BIND (rdList rd_spec xs4) _TO_ (specs, xs5) ->
-ToDo: do something for DeforestInfo
- RETN (GenPragmas arity upd strict unfold specs, xs5)
- BEND BEND BEND BEND BEND
+rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
+
+rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
+
+wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
+
+wlkGenPragma pragma
+ = case pragma of
+ U_no_pragma -> returnUgn noGenPragmas
+
+ U_igen_pragma aritee update deforest strct uf speccs ->
+ wlk_arity aritee `thenUgn` \ arity ->
+ wlk_update update `thenUgn` \ upd ->
+ wlk_deforest deforest `thenUgn` \ def ->
+ wlk_strict strct `thenUgn` \ strict ->
+ wlk_unfold uf `thenUgn` \ unfold ->
+ wlkList rd_spec speccs `thenUgn` \ specs ->
+ returnUgn (GenPragmas arity upd def strict unfold specs)
where
- rd_arity ('P' : 'N' : xs) = RETN (Nothing, xs)
- rd_arity ('P' : 'A' : xs)
- = BIND (rdIdString xs) _TO_ (a_str, xs1) ->
- RETN (Just ((read (_UNPK_ a_str))::Int), xs1)
- BEND
-
- rd_update ('P' : 'N' : xs) = RETN (Nothing, xs)
- rd_update ('P' : 'u' : xs)
- = BIND (rdIdString xs) _TO_ (upd_spec, xs1) ->
- RETN (Just ((read (_UNPK_ upd_spec))::UpdateInfo), xs1)
- BEND
-
- rd_unfold ('P' : 'N' : xs) = RETN (NoImpUnfolding, xs)
-
- rd_unfold ('P' : 'M' : xs)
- = BIND (rdIdString xs) _TO_ (str, xs1) ->
- RETN (ImpMagicUnfolding str, xs1)
- BEND
-
- rd_unfold ('P' : 'U' : xs)
- = BIND (rdGuidance xs) _TO_ (guidance, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (core, xs2) ->
- RETN (ImpUnfolding guidance core, xs2)
- BEND BEND
-
- rd_strict ('P' : 'N' : xs) = RETN (NoImpStrictness, xs)
- rd_strict ('P' : 'S' : xs)
- = BIND (rdString xs) _TO_ (strict_spec, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (wrkr_pragma, xs2) ->
- let
- ww_strict_info = (read (_UNPK_ strict_spec))::[Demand]
- in
- RETN (ImpStrictness (trace "ImpStrictness" False) ww_strict_info wrkr_pragma, xs2)
- BEND BEND
-
- rd_spec ('P' : '2' : xs)
- = BIND (rdList rdMonoTypeMaybe xs) _TO_ (mono_tys_maybe, xs1) ->
- BIND (rdIdString xs1) _TO_ (num_dicts, xs2) ->
- BIND (rdGenPragma xs2) _TO_ (gen_prag, xs3) ->
- RETN ((mono_tys_maybe, ((read (_UNPK_ num_dicts))::Int), gen_prag), xs3)
- BEND BEND BEND
+ wlk_arity stuff
+ = case stuff of
+ U_no_pragma -> returnUgn Nothing
+ U_iarity_pragma arity ->
+ returnUgn (Just arity)
+
+ ------------
+ wlk_update stuff
+ = case stuff of
+ U_no_pragma -> returnUgn Nothing
+ U_iupdate_pragma upd_spec ->
+ returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
+
+ ------------
+ wlk_deforest stuff
+ = case stuff of
+ U_no_pragma -> returnUgn Don'tDeforest
+ U_ideforest_pragma -> returnUgn DoDeforest
+
+ ------------
+ wlk_unfold stuff
+ = case stuff of
+ U_no_pragma -> returnUgn NoImpUnfolding
+
+ U_imagic_unfolding_pragma magic ->
+ returnUgn (ImpMagicUnfolding magic)
+
+ U_iunfolding_pragma guide core ->
+ wlkGuidance guide `thenUgn` \ guidance ->
+ wlkCoreExpr core `thenUgn` \ coresyn ->
+ returnUgn (ImpUnfolding guidance coresyn)
+
+ ------------
+ wlk_strict stuff
+ = case stuff of
+ U_no_pragma -> returnUgn NoImpStrictness
+
+ U_istrictness_pragma strict_spec wrkr_stuff ->
+ wlkGenPragma wrkr_stuff `thenUgn` \ wrkr_pragma ->
+ let
+ strict_spec_str = _UNPK_ strict_spec
+ (is_bot, ww_strict_info)
+ = if (strict_spec_str == "B")
+ then (True, [])
+ else (False, (read strict_spec_str)::[Demand])
+ in
+ returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
+
+ ------------
+ rd_spec pt
+ = rdU_hpragma pt `thenUgn` \ stuff ->
+ case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
+
+ wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe ->
+ wlkGenPragma prag `thenUgn` \ gen_prag ->
+ returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
\end{code}
The only tricky case is pragmas on signatures; we have no way of
whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
will sort it out later.
\begin{code}
-rdTySigPragmas :: String -> RETN_TYPE (RdrTySigPragmas, String)
+wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
-rdTySigPragmas ('P' : 'N' : xs) = RETN (RdrNoPragma, xs)
+wlkTySigPragmas pragma
+ = case pragma of
+ U_no_pragma -> returnUgn RdrNoPragma
-rdTySigPragmas ('P' : 'o' : xs)
- = BIND (rdGenPragma xs) _TO_ (dsel_pragma, xs1) ->
- BIND (rdGenPragma xs1) _TO_ (defm_pragma, xs2) ->
- RETN (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma), xs2)
- BEND BEND
+ U_iclasop_pragma dsel defm ->
+ wlkGenPragma dsel `thenUgn` \ dsel_pragma ->
+ wlkGenPragma defm `thenUgn` \ defm_pragma ->
+ returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
-rdTySigPragmas xs
- = BIND (rdGenPragma xs) _TO_ (gen_pragmas, xs1) ->
- RETN (RdrGenPragmas gen_pragmas, xs1)
- BEND
+ other ->
+ wlkGenPragma other `thenUgn` \ gen_pragmas ->
+ returnUgn (RdrGenPragmas gen_pragmas)
\end{code}
\begin{code}
-rdGuidance ('P' : 'x' : xs) = RETN (UnfoldAlways, xs)
-
--- EssentialUnfolding should never appear in interfaces, so we
--- don't have any way to read them.
-
-rdGuidance ('P' : 'y' : xs)
- = BIND (rdIdString xs) _TO_ (m_ty_args, xs1) ->
- BIND (rdIdString xs1) _TO_ (n_val_args, xs2) ->
- BIND (rdIdString xs2) _TO_ (con_arg_spec, xs3) ->
- BIND (rdIdString xs3) _TO_ (size_str, xs4) ->
- let
- num_val_args = ((read (_UNPK_ n_val_args)) :: Int)
- con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
- -- if there were 0 args, we want to throw away
- -- any dummy con_arg_spec stuff...
- in
- RETN (UnfoldIfGoodArgs (read (_UNPK_ m_ty_args)) num_val_args
- con_arg_info (read (_UNPK_ size_str)), xs4)
- BEND BEND BEND BEND
- where
- cvt 'C' = True -- want a constructor in this arg position
- cvt _ = False
-
-{- OLD:
-rdGuidance ('P' : 'z' : xs)
- = BIND (rdIdString xs) _TO_ (m_ty_args, xs1) ->
- BIND (rdIdString xs1) _TO_ (size, xs2) ->
- RETN (trace "read:UnfoldIsCon" UnfoldNever, xs2) -- ToDo: rm
- BEND BEND
--}
+wlkGuidance guide
+ = case guide of
+ U_iunfold_always -> returnUgn UnfoldAlways
+
+ U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
+ let
+ con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
+ -- if there were 0 args, we want to throw away
+ -- any dummy con_arg_spec stuff...
+ in
+ returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
+ con_arg_info size)
+ where
+ cvt 'C' = True -- want a constructor in this arg position
+ cvt _ = False
\end{code}
\begin{code}
-rdCoreExpr :: String -> RETN_TYPE (ProtoNameUnfoldingCoreExpr, String)
-
-rdCoreExpr ('F' : 'g' : xs)
- = BIND (rdCoreId xs) _TO_ (var, xs1) ->
- RETN (UfCoVar var, xs1)
- BEND
-
-rdCoreExpr ('F' : 'h' : xs)
- = BIND (rdBasicLit xs) _TO_ (lit, xs1) ->
- RETN (UfCoLit lit, xs1)
- BEND
-
-rdCoreExpr ('F' : 'i' : xs)
- = BIND (rdCoreId xs) _TO_ (BoringUfId con, xs1) ->
- BIND (rdList rdCoreType xs1) _TO_ (tys, xs2) ->
- BIND (rdList rdCoreAtom xs2) _TO_ (vs, xs3) ->
- RETN (UfCoCon con tys vs, xs3)
- BEND BEND BEND
-
-rdCoreExpr ('F' : 'j' : xs)
- = BIND (rd_primop xs) _TO_ (op, xs1) ->
- BIND (rdList rdCoreType xs1) _TO_ (tys, xs2) ->
- BIND (rdList rdCoreAtom xs2) _TO_ (vs, xs3) ->
- RETN (UfCoPrim op tys vs, xs3)
- BEND BEND BEND
- where
-
--- Question: why did ccall once panic if you looked at the maygc flag?
--- Was this just laziness or is it not needed? In that case, modify
--- the stuff that writes them to pragmas so that it never adds the _GC_
--- tag. ADR
-
- rd_primop ('F' : 'w' : xs)
- = BIND (rdIdString xs) _TO_ (op_str, xs1) ->
- RETN (UfOtherOp (readUnfoldingPrimOp op_str), xs1)
- BEND
- rd_primop ('F' : 'x' : t_or_f : xs)
- = BIND (rdIdString xs) _TO_ (fun_str, xs1) ->
- BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
- BIND (rdCoreType xs2) _TO_ (res_ty, xs3) ->
- RETN (UfCCallOp fun_str False (is_T_or_F t_or_f) arg_tys res_ty, xs3)
- BEND BEND BEND
- rd_primop ('F' : 'y' : t_or_f : xs)
- = BIND (rdBasicLit xs) _TO_ (casm_litlit, xs1) ->
- BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) ->
- BIND (rdCoreType xs2) _TO_ (res_ty, xs3) ->
+wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
+
+wlkCoreExpr core_expr
+ = case core_expr of
+ U_covar v ->
+ wlkCoreId v `thenUgn` \ var ->
+ returnUgn (UfVar var)
+
+ U_coliteral l ->
+ wlkBasicLit l `thenUgn` \ lit ->
+ returnUgn (UfLit lit)
+
+ U_cocon c ts as ->
+ wlkCoreId c `thenUgn` \ (BoringUfId con) ->
+ wlkList rdCoreType ts `thenUgn` \ tys ->
+ wlkList rdCoreAtom as `thenUgn` \ vs ->
+ returnUgn (UfCon con tys vs)
+
+ U_coprim o ts as ->
+ wlk_primop o `thenUgn` \ op ->
+ wlkList rdCoreType ts `thenUgn` \ tys ->
+ wlkList rdCoreAtom as `thenUgn` \ vs ->
let
- (MachLitLit casm_str _) = casm_litlit
+ fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
in
- RETN (UfCCallOp casm_str True (is_T_or_F t_or_f) arg_tys res_ty, xs3)
- BEND BEND BEND
-
- is_T_or_F 'T' = True
- is_T_or_F 'F' = False
-
-rdCoreExpr ('F' : 'k' : xs)
- = BIND (rdList rdCoreBinder xs) _TO_ (bs, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
- RETN (UfCoLam bs body, xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'l' : xs)
- = BIND (rdList rdId xs) _TO_ (tvs, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
- RETN (foldr UfCoTyLam body tvs, xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'm' : xs)
- = BIND (rdCoreExpr xs) _TO_ (fun, xs1) ->
- BIND (rdList rdCoreAtom xs1) _TO_ (args, xs2) ->
- RETN (foldl UfCoApp fun args, xs2)
- BEND BEND
-
-
-rdCoreExpr ('F' : 'n' : xs)
- = BIND (rdCoreExpr xs) _TO_ (expr, xs1) ->
- BIND (rdCoreType xs1) _TO_ (ty, xs2) ->
- RETN (UfCoTyApp expr ty, xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'o' : xs)
- = BIND (rdCoreExpr xs) _TO_ (scrut, xs1) ->
- BIND (rd_alts xs1) _TO_ (alts, xs2) ->
- RETN (UfCoCase scrut alts, xs2)
- BEND BEND
- where
- rd_alts ('F' : 'q' : xs)
- = BIND (rdList rd_alg_alt xs) _TO_ (alts, xs1) ->
- BIND (rd_deflt xs1) _TO_ (deflt, xs2) ->
- RETN (UfCoAlgAlts alts deflt, xs2)
- BEND BEND
- where
- rd_alg_alt ('F' : 'r' : xs)
- = BIND (rdCoreId xs) _TO_ (BoringUfId con, xs1) ->
- BIND (rdList rdCoreBinder xs1) _TO_ (params, xs2) ->
- BIND (rdCoreExpr xs2) _TO_ (rhs, xs3) ->
- RETN ((con, params, rhs), xs3)
- BEND BEND BEND
-
- rd_alts ('F' : 's' : xs)
- = BIND (rdList rd_prim_alt xs) _TO_ (alts, xs1) ->
- BIND (rd_deflt xs1) _TO_ (deflt, xs2) ->
- RETN (UfCoPrimAlts alts deflt, xs2)
- BEND BEND
- where
- rd_prim_alt ('F' : 't' : xs)
- = BIND (rdBasicLit xs) _TO_ (lit, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) ->
- RETN ((lit, rhs), xs2)
- BEND BEND
-
- rd_deflt ('F' : 'u' : xs) = RETN (UfCoNoDefault, xs)
- rd_deflt ('F' : 'v' : xs)
- = BIND (rdCoreBinder xs) _TO_ (b, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) ->
- RETN (UfCoBindDefault b rhs, xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'p' : xs)
- = BIND (rd_bind xs) _TO_ (bind, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
- RETN (UfCoLet bind body, xs2)
- BEND BEND
- where
- rd_bind ('F' : 'd' : xs)
- = BIND (rdCoreBinder xs) _TO_ (b, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) ->
- RETN (UfCoNonRec b rhs, xs2)
- BEND BEND
-
- rd_bind ('F' : 'e' : xs)
- = BIND (rdList rd_pair xs) _TO_ (pairs, xs1) ->
- RETN (UfCoRec pairs, xs1)
- BEND
+ returnUgn (UfPrim op tys fixed_vs)
+ where
+
+ -- Question: why did ccall once panic if you looked at the
+ -- maygc flag? Was this just laziness or is it not needed?
+ -- In that case, modify the stuff that writes them to pragmas
+ -- so that it never adds the _GC_ tag. ADR
+
+ wlk_primop op
+ = case op of
+ U_co_primop op_str ->
+ returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
+
+ U_co_ccall fun_str may_gc a_tys r_ty ->
+ wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
+ wlkCoreType r_ty `thenUgn` \ res_ty ->
+ returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
+
+ U_co_casm litlit may_gc a_tys r_ty ->
+ wlkBasicLit litlit `thenUgn` \ (MachLitLit casm_str _) ->
+ wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
+ wlkCoreType r_ty `thenUgn` \ res_ty ->
+ returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
+ where
+ is_T_or_F 0 = False
+ is_T_or_F _ = True
+
+ -- Now *this* is a hack: we can't distinguish Int# literals
+ -- from Word# literals as they come in; this is only likely
+ -- to bite on the args of certain PrimOps (shifts, etc); so
+ -- we look for those and fix things up!!! (WDP 95/05)
+
+ fixup AndOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup OrOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup NotOp [a1] = [fixarg a1]
+ fixup SllOp [a1, a2] = [fixarg a1, a2]
+ fixup SraOp [a1, a2] = [fixarg a1, a2]
+ fixup SrlOp [a1, a2] = [fixarg a1, a2]
+ fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
+ fixup _ as = as
+
+ fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
+ fixarg arg = arg
+
+ U_colam vars expr ->
+ wlkList rdCoreBinder vars `thenUgn` \ bs ->
+ wlkCoreExpr expr `thenUgn` \ body ->
+ returnUgn (foldr UfLam body bs)
+
+ U_coapp f as ->
+ wlkCoreExpr f `thenUgn` \ fun ->
+ wlkList rdCoreAtom as `thenUgn` \ args ->
+ returnUgn (foldl UfApp fun args)
+
+ U_cocase s as ->
+ wlkCoreExpr s `thenUgn` \ scrut ->
+ wlk_alts as `thenUgn` \ alts ->
+ returnUgn (UfCase scrut alts)
+ where
+ wlk_alts (U_coalg_alts as d)
+ = wlkList rd_alg_alt as `thenUgn` \ alts ->
+ wlk_deflt d `thenUgn` \ deflt ->
+ returnUgn (UfCoAlgAlts alts deflt)
+ where
+ rd_alg_alt pt
+ = rdU_coresyn pt `thenUgn` \ (U_coalg_alt c bs exp) ->
+
+ wlkCoreId c `thenUgn` \ (BoringUfId con) ->
+ wlkList rdCoreBinder bs `thenUgn` \ params ->
+ wlkCoreExpr exp `thenUgn` \ rhs ->
+ returnUgn (con, params, rhs)
+
+ wlk_alts (U_coprim_alts as d)
+ = wlkList rd_prim_alt as `thenUgn` \ alts ->
+ wlk_deflt d `thenUgn` \ deflt ->
+ returnUgn (UfCoPrimAlts alts deflt)
+ where
+ rd_prim_alt pt
+ = rdU_coresyn pt `thenUgn` \ (U_coprim_alt l exp) ->
+
+ wlkBasicLit l `thenUgn` \ lit ->
+ wlkCoreExpr exp `thenUgn` \ rhs ->
+ returnUgn (lit, rhs)
+
+ wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
+ wlk_deflt (U_cobinddeflt v exp)
+ = wlkCoreBinder v `thenUgn` \ b ->
+ wlkCoreExpr exp `thenUgn` \ rhs ->
+ returnUgn (UfCoBindDefault b rhs)
+
+ U_colet b expr ->
+ wlk_bind b `thenUgn` \ bind ->
+ wlkCoreExpr expr `thenUgn` \ body ->
+ returnUgn (UfLet bind body)
+ where
+ wlk_bind (U_cononrec v expr)
+ = wlkCoreBinder v `thenUgn` \ b ->
+ wlkCoreExpr expr `thenUgn` \ rhs ->
+ returnUgn (UfCoNonRec b rhs)
+
+ wlk_bind (U_corec prs)
+ = wlkList rd_pair prs `thenUgn` \ pairs ->
+ returnUgn (UfCoRec pairs)
+ where
+ rd_pair pt
+ = rdU_coresyn pt `thenUgn` \ (U_corec_pair v expr) ->
+
+ wlkCoreBinder v `thenUgn` \ b ->
+ wlkCoreExpr expr `thenUgn` \ rhs ->
+ returnUgn (b, rhs)
+
+ U_coscc c expr ->
+ wlk_cc c `thenUgn` \ cc ->
+ wlkCoreExpr expr `thenUgn` \ body ->
+ returnUgn (UfSCC cc body)
where
- rd_pair ('F' : 'f' : xs)
- = BIND (rdCoreBinder xs) _TO_ (b, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) ->
- RETN ((b, rhs), xs2)
- BEND BEND
-
-rdCoreExpr ('F' : 'z' : xs)
- = BIND (rd_cc xs) _TO_ (cc, xs1) ->
- BIND (rdCoreExpr xs1) _TO_ (body, xs2) ->
- RETN (UfCoSCC cc body, xs2)
- BEND BEND
- where
- rd_cc ('F' : '?' : 'a' : xs)
- = BIND (rd_dupd xs) _TO_ (is_dupd, xs1) ->
- RETN (UfPreludeDictsCC is_dupd, xs1)
- BEND
-
- rd_cc ('F' : '?' : 'b' : xs)
- = BIND (rdString xs) _TO_ (m, xs1) ->
- BIND (rdString xs1) _TO_ (g, xs2) ->
- BIND (rd_dupd xs2) _TO_ (is_dupd, xs3) ->
- RETN (UfAllDictsCC m g is_dupd, xs3)
- BEND BEND BEND
-
- rd_cc ('F' : '?' : 'c' : xs)
- = BIND (rdString xs) _TO_ (n, xs1) ->
- BIND (rdString xs1) _TO_ (m, xs2) ->
- BIND (rdString xs2) _TO_ (g, xs3) ->
- BIND (rd_dupd xs3) _TO_ (is_dupd, xs4) ->
- BIND (rd_cafd xs4) _TO_ (is_cafd, xs5) ->
- RETN (UfUserCC n m g is_dupd is_cafd, xs5)
- BEND BEND BEND BEND BEND
-
- rd_cc ('F' : '?' : 'd' : xs)
- = BIND (rdCoreId xs) _TO_ (i, xs1) ->
- BIND (rdString xs1) _TO_ (m, xs2) ->
- BIND (rdString xs2) _TO_ (g, xs3) ->
- BIND (rd_dupd xs3) _TO_ (is_dupd, xs4) ->
- BIND (rd_cafd xs4) _TO_ (is_cafd, xs5) ->
- RETN (UfAutoCC i m g is_dupd is_cafd, xs5)
- BEND BEND BEND BEND BEND
-
- rd_cc ('F' : '?' : 'e' : xs)
- = BIND (rdCoreId xs) _TO_ (i, xs1) ->
- BIND (rdString xs1) _TO_ (m, xs2) ->
- BIND (rdString xs2) _TO_ (g, xs3) ->
- BIND (rd_dupd xs3) _TO_ (is_dupd, xs4) ->
- BIND (rd_cafd xs4) _TO_ (is_cafd, xs5) ->
- RETN (UfDictCC i m g is_dupd is_cafd, xs5)
- BEND BEND BEND BEND BEND
-
- ------
- rd_cafd ('F' : '?' : 'f' : xs) = RETN (False, xs)
- rd_cafd ('F' : '?' : 'g' : xs) = RETN (True, xs)
--- rd_cafd xs = panic ("rd_cafd:\n"++xs)
-
- rd_dupd ('F' : '?' : 'h' : xs) = RETN (False, xs)
- rd_dupd ('F' : '?' : 'i' : xs) = RETN (True, xs)
+ wlk_cc (U_co_preludedictscc dupd)
+ = wlk_dupd dupd `thenUgn` \ is_dupd ->
+ returnUgn (UfPreludeDictsCC is_dupd)
+
+ wlk_cc (U_co_alldictscc m g dupd)
+ = wlk_dupd dupd `thenUgn` \ is_dupd ->
+ returnUgn (UfAllDictsCC m g is_dupd)
+
+ wlk_cc (U_co_usercc n m g dupd cafd)
+ = wlk_dupd dupd `thenUgn` \ is_dupd ->
+ wlk_cafd cafd `thenUgn` \ is_cafd ->
+ returnUgn (UfUserCC n m g is_dupd is_cafd)
+
+ wlk_cc (U_co_autocc id m g dupd cafd)
+ = wlkCoreId id `thenUgn` \ i ->
+ wlk_dupd dupd `thenUgn` \ is_dupd ->
+ wlk_cafd cafd `thenUgn` \ is_cafd ->
+ returnUgn (UfAutoCC i m g is_dupd is_cafd)
+
+ wlk_cc (U_co_dictcc id m g dupd cafd)
+ = wlkCoreId id `thenUgn` \ i ->
+ wlk_dupd dupd `thenUgn` \ is_dupd ->
+ wlk_cafd cafd `thenUgn` \ is_cafd ->
+ returnUgn (UfDictCC i m g is_dupd is_cafd)
+
+ ------
+ wlk_cafd U_co_scc_noncaf = returnUgn False
+ wlk_cafd U_co_scc_caf = returnUgn True
+
+ wlk_dupd U_co_scc_nondupd = returnUgn False
+ wlk_dupd U_co_scc_dupd = returnUgn True
\end{code}
\begin{code}
-rdCoreBinder ('F' : 'a' : xs)
- = BIND (rdId xs) _TO_ (b, xs1) ->
- BIND (rdCoreType xs1) _TO_ (ty, xs2) ->
- RETN ((b, ty), xs2)
- BEND BEND
-
-rdCoreAtom ('F' : 'b' : xs)
- = BIND (rdBasicLit xs) _TO_ (lit, xs1) ->
- RETN (UfCoLitAtom lit, xs1)
- BEND
-
-rdCoreAtom ('F' : 'c' : xs)
- = BIND (rdCoreId xs) _TO_ (v, xs1) ->
- RETN (UfCoVarAtom v, xs1)
- BEND
-\end{code}
+type ProtoUfBinder = (ProtoName, PolyType ProtoName)
-\begin{code}
-rdCoreType :: String -> RETN_TYPE (ProtoNamePolyType, String)
-
-rdCoreType ('2' : 'C' : xs)
- = BIND (rdList rdId xs) _TO_ (tvs, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (ForAllTy tvs ty, xs2)
- BEND BEND
-
-rdCoreType other
- = BIND (rdMonoType other) _TO_ (ty, xs1) ->
- RETN (UnoverloadedTy ty, xs1)
- BEND
+rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
+
+rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
+
+wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
+
+wlkCoreBinder (U_cobinder b t)
+ = wlkCoreType t `thenUgn` \ ty ->
+ returnUgn (b, ty)
+
+rdCoreAtom pt
+ = rdU_coresyn pt `thenUgn` \ atom ->
+ case atom of
+ U_colit l ->
+ wlkBasicLit l `thenUgn` \ lit ->
+ returnUgn (UfCoLitAtom lit)
+
+ U_colocal var ->
+ wlkCoreId var `thenUgn` \ v ->
+ returnUgn (UfCoVarAtom v)
\end{code}
\begin{code}
-rdCoreTypeMaybe :: String -> RETN_TYPE(Maybe ProtoNamePolyType, String)
+rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
+
+rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
+
+wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
-rdCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs)
-rdCoreTypeMaybe ('2' : 'E' : xs)
- = BIND (rdCoreType xs) _TO_ (ty, xs1) ->
- RETN(Just ty, xs1)
- BEND
+wlkCoreType other
+ = panic "ReadPragmas:wlkCoreType:ToDo"
+{- LATER:
+wlkCoreType (U_uniforall ts t)
+ = wlkList rdU_???unkId ts `thenUgn` \ tvs ->
+ wlkMonoType t `thenUgn` \ ty ->
+ returnUgn (HsForAllTy tvs ty)
-rdMonoTypeMaybe ('2' : 'D' : xs) = RETN (Nothing, xs)
+wlkCoreType other
+ = wlkMonoType other `thenUgn` \ ty ->
+ returnUgn (UnoverloadedTy ty)
+-}
+\end{code}
-rdMonoTypeMaybe ('2' : 'E' : xs)
- = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) ->
- RETN (Just mono_ty, xs1)
- BEND
+\begin{code}
+rdMonoTypeMaybe pt
+ = rdU_maybe pt `thenUgn` \ ty_maybe ->
+ wlkMaybe rdMonoType ty_maybe
\end{code}
\begin{code}
-rdCoreId :: String -> RETN_TYPE (UfId ProtoName, String)
-
-rdCoreId ('F' : '1' : xs)
- = BIND (rdIdString xs) _TO_ (v, xs1) ->
- RETN (BoringUfId (cvt_IdString v), xs1)
- BEND
-rdCoreId ('F' : '9' : xs)
- = BIND (rdIdString xs) _TO_ (mod, xs1) ->
- BIND (rdIdString xs1) _TO_ (nm, xs2) ->
- RETN (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm), xs2)
- BEND BEND
-rdCoreId ('F' : '2' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdId xs1) _TO_ (super_clas, xs2) ->
- RETN (SuperDictSelUfId clas super_clas, xs2)
- BEND BEND
-rdCoreId ('F' : '3' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdId xs1) _TO_ (method, xs2) ->
- RETN (ClassOpUfId clas method, xs2)
- BEND BEND
-rdCoreId ('F' : '4' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdId xs1) _TO_ (method, xs2) ->
- RETN (DefaultMethodUfId clas method, xs2)
- BEND BEND
-rdCoreId ('F' : '5' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdCoreType xs1) _TO_ (ty, xs2) ->
- RETN (DictFunUfId clas ty, xs2)
- BEND BEND
-rdCoreId ('F' : '6' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdId xs1) _TO_ (op, xs2) ->
- BIND (rdCoreType xs2) _TO_ (ty, xs3) ->
- RETN (ConstMethodUfId clas op ty, xs3)
- BEND BEND BEND
-rdCoreId ('F' : '7' : xs)
- = BIND (rdCoreId xs) _TO_ (unspec, xs1) ->
- BIND (rdList rdMonoTypeMaybe xs1) _TO_ (ty_maybes, xs2) ->
- RETN (SpecUfId unspec ty_maybes, xs2)
- BEND BEND
-rdCoreId ('F' : '8' : xs)
- = BIND (rdCoreId xs) _TO_ (unwrkr, xs1) ->
- RETN (WorkerUfId unwrkr, xs1)
- BEND
+wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
+
+wlkCoreId (U_co_id v)
+ = returnUgn (BoringUfId (cvt_IdString v))
+
+wlkCoreId (U_co_orig_id mod nm)
+ = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
+
+wlkCoreId (U_co_sdselid clas super_clas)
+ = returnUgn (SuperDictSelUfId clas super_clas)
+
+wlkCoreId (U_co_classopid clas method)
+ = returnUgn (ClassOpUfId clas method)
+
+wlkCoreId (U_co_defmid clas method)
+ = returnUgn (DefaultMethodUfId clas method)
+wlkCoreId (U_co_dfunid clas t)
+ = wlkCoreType t `thenUgn` \ ty ->
+ returnUgn (DictFunUfId clas ty)
+
+wlkCoreId (U_co_constmid clas op t)
+ = wlkCoreType t `thenUgn` \ ty ->
+ returnUgn (ConstMethodUfId clas op ty)
+
+wlkCoreId (U_co_specid id tys)
+ = wlkCoreId id `thenUgn` \ unspec ->
+ wlkList rdMonoTypeMaybe tys `thenUgn` \ ty_maybes ->
+ returnUgn (SpecUfId unspec ty_maybes)
+
+wlkCoreId (U_co_wrkrid un)
+ = wlkCoreId un `thenUgn` \ unwrkr ->
+ returnUgn (WorkerUfId unwrkr)
+
+------------
cvt_IdString :: FAST_STRING -> ProtoName
cvt_IdString s
= if (_HEAD_ s /= '_') then
boring
else if (sub_s == SLIT("NIL_")) then
--- trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
Prel (WiredInVal nilDataCon)
--- )
else if (sub_s == SLIT("TUP_")) then
--- trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
Prel (WiredInVal (mkTupleCon arity))
--- )
else
--- trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
boring
--- )
where
boring = Unk s
sub_s = _SUBSTR_ s 1 4 -- chars 1--4 (0-origin)
\end{code}
\begin{code}
-rdBasicLit :: String -> RETN_TYPE (BasicLit, String)
+wlkBasicLit :: U_literal -> UgnM Literal
-rdBasicLit ('R' : xs)
- = BIND (rdString xs) _TO_ (n, xs1) ->
- BIND (rdString xs1) _TO_ (d, xs2) ->
- let
+wlkBasicLit (U_norepr n d)
+ = let
num = ((read (_UNPK_ n)) :: Integer)
den = ((read (_UNPK_ d)) :: Integer)
in
- RETN (NoRepRational (num % den), xs2)
- BEND BEND
-
-rdBasicLit ( tag : xs)
- = BIND (rdString xs) _TO_ (x, zs) ->
- let
- s = _UNPK_ x
-
- as_char = chr ((read s) :: Int)
- -- a char comes in as a number string
- -- representing its ASCII code
- as_integer = readInteger s
-#ifdef __GLASGOW_HASKELL__
- as_rational = _readRational s -- non-std
-#else
- as_rational = ((read s)::Rational)
-#endif
- as_double = ((read s) :: Double)
- in
- case tag of {
- 'H' -> RETN (mkMachInt as_integer, zs);
- 'J' -> RETN (MachDouble as_rational,zs);
- 'K' -> RETN (MachFloat as_rational,zs);
- 'P' -> RETN (MachChar as_char, zs);
- 'V' -> RETN (MachStr x, zs);
- 'Y' -> BIND (rdString zs) _TO_ (k, zs2) ->
- RETN (MachLitLit x (guessPrimKind k), zs2)
- BEND;
- 'I' -> RETN (NoRepInteger as_integer, zs);
- 's' -> RETN (NoRepStr x, zs)
- } BEND
+ returnUgn (NoRepRational (num % den))
+
+wlkBasicLit other
+ = returnUgn (
+ case other of
+ U_intprim s -> mkMachInt (as_integer s)
+ U_doubleprim s -> MachDouble (as_rational s)
+ U_floatprim s -> MachFloat (as_rational s)
+ U_charprim s -> MachChar (as_char s)
+ U_stringprim s -> MachStr (as_string s)
+
+ U_clitlit s k -> MachLitLit (as_string s) (guessPrimRep (_UNPK_ k))
+
+ U_norepi s -> NoRepInteger (as_integer s)
+ U_noreps s -> NoRepStr (as_string s)
+ )
+ where
+ as_char s = _HEAD_ s
+ as_integer s = readInteger (_UNPK_ s)
+ as_rational s = _readRational (_UNPK_ s) -- non-std
+ as_string s = s
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ReadPragmas2 where
-import HsPragmas(ClassPragmas, DataPragmas, InstancePragmas, TypePragmas)
-import HsTypes(PolyType)
-import Maybes(Labda)
-import PrefixSyn(RdrTySigPragmas)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-import U_hpragma(U_hpragma)
-type ProtoUfBinder = (ProtoName, PolyType ProtoName)
-wlkClassPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (ClassPragmas ProtoName, _State _RealWorld)
-wlkDataPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (DataPragmas ProtoName, _State _RealWorld)
-wlkInstPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> ((Labda _PackedString, InstancePragmas ProtoName), _State _RealWorld)
-wlkTySigPragmas :: U_hpragma -> _PackedString -> _State _RealWorld -> (RdrTySigPragmas, _State _RealWorld)
-wlkTypePragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (TypePragmas, _State _RealWorld)
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
-%
-\section[ReadPragmas2]{Read pragmatic interface info, including Core}
-
-\begin{code}
-#include "HsVersions.h"
-
-module ReadPragmas2 (
- ProtoUfBinder(..),
-
- wlkClassPragma,
- wlkDataPragma,
- wlkInstPragma,
- wlkTySigPragmas,
- wlkTypePragma
- ) where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-
-import UgenAll
-
-import AbsPrel ( nilDataCon, readUnfoldingPrimOp, PrimOp(..)
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import PrimKind ( guessPrimKind, PrimKind )
-import AbsSyn
-import BasicLit ( mkMachInt, BasicLit(..) )
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import Id ( mkTupleCon )
-import IdInfo -- ( UnfoldingGuidance(..) )
-import Maybes ( Maybe(..) )
-import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
-import ReadPrefix2 ( wlkList, rdConDecl, wlkMonoType )
-import Util
-\end{code}
-
-\begin{code}
-wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
-
-wlkDataPragma pragma
- = case pragma of
- U_no_pragma -> returnUgn (DataPragmas [] [])
- U_idata_pragma cs ss ->
- wlkList rdConDecl cs `thenUgn` \ cons ->
- wlkList rd_spec ss `thenUgn` \ specs ->
- returnUgn (DataPragmas cons specs)
- where
- rd_spec pt
- = rdU_hpragma pt `thenUgn` \ stuff ->
- case stuff of { U_idata_pragma_4s ss ->
-
- wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
- returnUgn specs }
-\end{code}
-
-\begin{code}
-wlkTypePragma :: U_hpragma -> UgnM TypePragmas
-
-wlkTypePragma pragma
- = case pragma of
- U_no_pragma -> returnUgn NoTypePragmas
- U_itype_pragma -> returnUgn AbstractTySynonym
-\end{code}
-
-\begin{code}
-wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
-
-wlkClassPragma pragma
- = case pragma of
- U_no_pragma -> returnUgn NoClassPragmas
- U_iclas_pragma gens ->
- wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
- ASSERT(not (null gen_pragmas))
- returnUgn (SuperDictPragmas gen_pragmas)
-\end{code}
-
-\begin{code}
-wlkInstPragma :: U_hpragma -> UgnM (Maybe FAST_STRING, ProtoNameInstancePragmas)
-
-wlkInstPragma pragma
- = case pragma of
- U_no_pragma -> returnUgn (Nothing, NoInstancePragmas)
-
- U_iinst_simpl_pragma modname dfun_gen ->
- wlkGenPragma dfun_gen `thenUgn` \ gen_pragmas ->
- returnUgn (Just modname, SimpleInstancePragma gen_pragmas)
-
- U_iinst_const_pragma modname dfun_gen constm_stuff ->
- wlkGenPragma dfun_gen `thenUgn` \ gen_pragma ->
- wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
- returnUgn (Just modname, ConstantInstancePragma gen_pragma constm_pragmas)
-
-rd_constm pt
- = rdU_hpragma pt `thenUgn` \ stuff ->
- case stuff of { U_iname_pragma_pr name gen ->
-
- wlkGenPragma gen `thenUgn` \ prag ->
- returnUgn (name, prag) }
-\end{code}
-
-\begin{code}
-rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
-
-rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
-
-wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
-
-wlkGenPragma pragma
- = case pragma of
- U_no_pragma -> returnUgn NoGenPragmas
-
- U_igen_pragma aritee update deforest strct uf speccs ->
- wlk_arity aritee `thenUgn` \ arity ->
- wlk_update update `thenUgn` \ upd ->
- wlk_deforest deforest `thenUgn` \ def ->
- wlk_strict strct `thenUgn` \ strict ->
- wlk_unfold uf `thenUgn` \ unfold ->
- wlkList rd_spec speccs `thenUgn` \ specs ->
- returnUgn (GenPragmas arity upd def strict unfold specs)
- where
- wlk_arity stuff
- = case stuff of
- U_no_pragma -> returnUgn Nothing
- U_iarity_pragma arity ->
- returnUgn (Just arity)
-
- ------------
- wlk_update stuff
- = case stuff of
- U_no_pragma -> returnUgn Nothing
- U_iupdate_pragma upd_spec ->
- returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
-
- ------------
- wlk_deforest stuff
- = case stuff of
- U_no_pragma -> returnUgn Don'tDeforest
- U_ideforest_pragma -> returnUgn DoDeforest
-
- ------------
- wlk_unfold stuff
- = case stuff of
- U_no_pragma -> returnUgn NoImpUnfolding
-
- U_imagic_unfolding_pragma magic ->
- returnUgn (ImpMagicUnfolding magic)
-
- U_iunfolding_pragma guide core ->
- wlkGuidance guide `thenUgn` \ guidance ->
- wlkCoreExpr core `thenUgn` \ coresyn ->
- returnUgn (ImpUnfolding guidance coresyn)
-
- ------------
- wlk_strict stuff
- = case stuff of
- U_no_pragma -> returnUgn NoImpStrictness
-
- U_istrictness_pragma strict_spec wrkr_stuff ->
- wlkGenPragma wrkr_stuff `thenUgn` \ wrkr_pragma ->
- let
- strict_spec_str = _UNPK_ strict_spec
- (is_bot, ww_strict_info)
- = if (strict_spec_str == "B")
- then (True, [])
- else (False, (read strict_spec_str)::[Demand])
- in
- returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
-
- ------------
- rd_spec pt
- = rdU_hpragma pt `thenUgn` \ stuff ->
- case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
-
- wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe ->
- wlkGenPragma prag `thenUgn` \ gen_prag ->
- returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
-\end{code}
-
-The only tricky case is pragmas on signatures; we have no way of
-knowing whether it is a @GenPragma@ or a @ClassOp@ pragma. So we read
-whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
-will sort it out later.
-\begin{code}
-wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
-
-wlkTySigPragmas pragma
- = case pragma of
- U_no_pragma -> returnUgn RdrNoPragma
-
- U_iclasop_pragma dsel defm ->
- wlkGenPragma dsel `thenUgn` \ dsel_pragma ->
- wlkGenPragma defm `thenUgn` \ defm_pragma ->
- returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
-
- other ->
- wlkGenPragma other `thenUgn` \ gen_pragmas ->
- returnUgn (RdrGenPragmas gen_pragmas)
-\end{code}
-
-\begin{code}
-wlkGuidance guide
- = case guide of
- U_iunfold_always -> returnUgn UnfoldAlways
-
- U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
- let
- con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
- -- if there were 0 args, we want to throw away
- -- any dummy con_arg_spec stuff...
- in
- returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
- con_arg_info size)
- where
- cvt 'C' = True -- want a constructor in this arg position
- cvt _ = False
-\end{code}
-
-\begin{code}
-wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
-
-wlkCoreExpr core_expr
- = case core_expr of
- U_covar v ->
- wlkCoreId v `thenUgn` \ var ->
- returnUgn (UfCoVar var)
-
- U_coliteral l ->
- wlkBasicLit l `thenUgn` \ lit ->
- returnUgn (UfCoLit lit)
-
- U_cocon c ts as ->
- wlkCoreId c `thenUgn` \ (BoringUfId con) ->
- wlkList rdCoreType ts `thenUgn` \ tys ->
- wlkList rdCoreAtom as `thenUgn` \ vs ->
- returnUgn (UfCoCon con tys vs)
-
- U_coprim o ts as ->
- wlk_primop o `thenUgn` \ op ->
- wlkList rdCoreType ts `thenUgn` \ tys ->
- wlkList rdCoreAtom as `thenUgn` \ vs ->
- let
- fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
- in
- returnUgn (UfCoPrim op tys fixed_vs)
- where
-
- -- Question: why did ccall once panic if you looked at the
- -- maygc flag? Was this just laziness or is it not needed?
- -- In that case, modify the stuff that writes them to pragmas
- -- so that it never adds the _GC_ tag. ADR
-
- wlk_primop op
- = case op of
- U_co_primop op_str ->
- returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
-
- U_co_ccall fun_str may_gc a_tys r_ty ->
- wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
- wlkCoreType r_ty `thenUgn` \ res_ty ->
- returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
-
- U_co_casm litlit may_gc a_tys r_ty ->
- wlkBasicLit litlit `thenUgn` \ (MachLitLit casm_str _) ->
- wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
- wlkCoreType r_ty `thenUgn` \ res_ty ->
- returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
- where
- is_T_or_F 0 = False
- is_T_or_F _ = True
-
- -- Now *this* is a hack: we can't distinguish Int# literals
- -- from Word# literals as they come in; this is only likely
- -- to bite on the args of certain PrimOps (shifts, etc); so
- -- we look for those and fix things up!!! (WDP 95/05)
-
- fixup AndOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup OrOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup NotOp [a1] = [fixarg a1]
- fixup SllOp [a1, a2] = [fixarg a1, a2]
- fixup SraOp [a1, a2] = [fixarg a1, a2]
- fixup SrlOp [a1, a2] = [fixarg a1, a2]
- fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup _ as = as
-
- fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
- fixarg arg = arg
-
- U_colam vars expr ->
- wlkList rdCoreBinder vars `thenUgn` \ bs ->
- wlkCoreExpr expr `thenUgn` \ body ->
- returnUgn (UfCoLam bs body)
-
- U_cotylam vars expr ->
- wlkList rdU_unkId vars `thenUgn` \ tvs ->
- wlkCoreExpr expr `thenUgn` \ body ->
- returnUgn (foldr UfCoTyLam body tvs)
-
- U_coapp f as ->
- wlkCoreExpr f `thenUgn` \ fun ->
- wlkList rdCoreAtom as `thenUgn` \ args ->
- returnUgn (foldl UfCoApp fun args)
-
- U_cotyapp e t ->
- wlkCoreExpr e `thenUgn` \ expr ->
- wlkCoreType t `thenUgn` \ ty ->
- returnUgn (UfCoTyApp expr ty)
-
- U_cocase s as ->
- wlkCoreExpr s `thenUgn` \ scrut ->
- wlk_alts as `thenUgn` \ alts ->
- returnUgn (UfCoCase scrut alts)
- where
- wlk_alts (U_coalg_alts as d)
- = wlkList rd_alg_alt as `thenUgn` \ alts ->
- wlk_deflt d `thenUgn` \ deflt ->
- returnUgn (UfCoAlgAlts alts deflt)
- where
- rd_alg_alt pt
- = rdU_coresyn pt `thenUgn` \ (U_coalg_alt c bs exp) ->
-
- wlkCoreId c `thenUgn` \ (BoringUfId con) ->
- wlkList rdCoreBinder bs `thenUgn` \ params ->
- wlkCoreExpr exp `thenUgn` \ rhs ->
- returnUgn (con, params, rhs)
-
- wlk_alts (U_coprim_alts as d)
- = wlkList rd_prim_alt as `thenUgn` \ alts ->
- wlk_deflt d `thenUgn` \ deflt ->
- returnUgn (UfCoPrimAlts alts deflt)
- where
- rd_prim_alt pt
- = rdU_coresyn pt `thenUgn` \ (U_coprim_alt l exp) ->
-
- wlkBasicLit l `thenUgn` \ lit ->
- wlkCoreExpr exp `thenUgn` \ rhs ->
- returnUgn (lit, rhs)
-
- wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
- wlk_deflt (U_cobinddeflt v exp)
- = wlkCoreBinder v `thenUgn` \ b ->
- wlkCoreExpr exp `thenUgn` \ rhs ->
- returnUgn (UfCoBindDefault b rhs)
-
- U_colet b expr ->
- wlk_bind b `thenUgn` \ bind ->
- wlkCoreExpr expr `thenUgn` \ body ->
- returnUgn (UfCoLet bind body)
- where
- wlk_bind (U_cononrec v expr)
- = wlkCoreBinder v `thenUgn` \ b ->
- wlkCoreExpr expr `thenUgn` \ rhs ->
- returnUgn (UfCoNonRec b rhs)
-
- wlk_bind (U_corec prs)
- = wlkList rd_pair prs `thenUgn` \ pairs ->
- returnUgn (UfCoRec pairs)
- where
- rd_pair pt
- = rdU_coresyn pt `thenUgn` \ (U_corec_pair v expr) ->
-
- wlkCoreBinder v `thenUgn` \ b ->
- wlkCoreExpr expr `thenUgn` \ rhs ->
- returnUgn (b, rhs)
-
- U_coscc c expr ->
- wlk_cc c `thenUgn` \ cc ->
- wlkCoreExpr expr `thenUgn` \ body ->
- returnUgn (UfCoSCC cc body)
- where
- wlk_cc (U_co_preludedictscc dupd)
- = wlk_dupd dupd `thenUgn` \ is_dupd ->
- returnUgn (UfPreludeDictsCC is_dupd)
-
- wlk_cc (U_co_alldictscc m g dupd)
- = wlk_dupd dupd `thenUgn` \ is_dupd ->
- returnUgn (UfAllDictsCC m g is_dupd)
-
- wlk_cc (U_co_usercc n m g dupd cafd)
- = wlk_dupd dupd `thenUgn` \ is_dupd ->
- wlk_cafd cafd `thenUgn` \ is_cafd ->
- returnUgn (UfUserCC n m g is_dupd is_cafd)
-
- wlk_cc (U_co_autocc id m g dupd cafd)
- = wlkCoreId id `thenUgn` \ i ->
- wlk_dupd dupd `thenUgn` \ is_dupd ->
- wlk_cafd cafd `thenUgn` \ is_cafd ->
- returnUgn (UfAutoCC i m g is_dupd is_cafd)
-
- wlk_cc (U_co_dictcc id m g dupd cafd)
- = wlkCoreId id `thenUgn` \ i ->
- wlk_dupd dupd `thenUgn` \ is_dupd ->
- wlk_cafd cafd `thenUgn` \ is_cafd ->
- returnUgn (UfDictCC i m g is_dupd is_cafd)
-
- ------
- wlk_cafd U_co_scc_noncaf = returnUgn False
- wlk_cafd U_co_scc_caf = returnUgn True
-
- wlk_dupd U_co_scc_nondupd = returnUgn False
- wlk_dupd U_co_scc_dupd = returnUgn True
-\end{code}
-
-\begin{code}
-type ProtoUfBinder = (ProtoName, PolyType ProtoName)
-
-rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
-
-rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
-
-wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
-
-wlkCoreBinder (U_cobinder b t)
- = wlkCoreType t `thenUgn` \ ty ->
- returnUgn (b, ty)
-
-rdCoreAtom pt
- = rdU_coresyn pt `thenUgn` \ atom ->
- case atom of
- U_colit l ->
- wlkBasicLit l `thenUgn` \ lit ->
- returnUgn (UfCoLitAtom lit)
-
- U_colocal var ->
- wlkCoreId var `thenUgn` \ v ->
- returnUgn (UfCoVarAtom v)
-\end{code}
-
-\begin{code}
-rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
-
-rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
-
-wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
-
-wlkCoreType (U_uniforall ts t)
- = wlkList rdU_unkId ts `thenUgn` \ tvs ->
- wlkMonoType t `thenUgn` \ ty ->
- returnUgn (ForAllTy tvs ty)
-
-wlkCoreType other
- = wlkMonoType other `thenUgn` \ ty ->
- returnUgn (UnoverloadedTy ty)
-\end{code}
-
-\begin{code}
-{- OLD???
-wlkCoreTypeMaybe :: ParseTree -> RETN_TYPE(Maybe ProtoNamePolyType, FAST_STRING)
-
-wlkCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs)
-wlkCoreTypeMaybe ('2' : 'E' : xs)
- = wlkCoreType xs) `thenUgn` \ (ty, xs1) ->
- RETN(Just ty, xs1)
- BEND
--}
-
-rdMonoTypeMaybe pt
- = rdU_ttype pt `thenUgn` \ ty ->
- case ty of
- U_ty_maybe_nothing -> returnUgn Nothing
-
- U_ty_maybe_just t ->
- wlkMonoType t `thenUgn` \ mono_ty ->
- returnUgn (Just mono_ty)
-\end{code}
-
-\begin{code}
-wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
-
-wlkCoreId (U_co_id v)
- = returnUgn (BoringUfId (cvt_IdString v))
-
-wlkCoreId (U_co_orig_id mod nm)
- = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
-
-wlkCoreId (U_co_sdselid clas super_clas)
- = returnUgn (SuperDictSelUfId clas super_clas)
-
-wlkCoreId (U_co_classopid clas method)
- = returnUgn (ClassOpUfId clas method)
-
-wlkCoreId (U_co_defmid clas method)
- = returnUgn (DefaultMethodUfId clas method)
-
-wlkCoreId (U_co_dfunid clas t)
- = wlkCoreType t `thenUgn` \ ty ->
- returnUgn (DictFunUfId clas ty)
-
-wlkCoreId (U_co_constmid clas op t)
- = wlkCoreType t `thenUgn` \ ty ->
- returnUgn (ConstMethodUfId clas op ty)
-
-wlkCoreId (U_co_specid id tys)
- = wlkCoreId id `thenUgn` \ unspec ->
- wlkList rdMonoTypeMaybe tys `thenUgn` \ ty_maybes ->
- returnUgn (SpecUfId unspec ty_maybes)
-
-wlkCoreId (U_co_wrkrid un)
- = wlkCoreId un `thenUgn` \ unwrkr ->
- returnUgn (WorkerUfId unwrkr)
-
-------------
-cvt_IdString :: FAST_STRING -> ProtoName
-
-cvt_IdString s
- = if (_HEAD_ s /= '_') then
--- trace (show s++(show (_HEAD_ s /= '_'))++(_HEAD_ s):'_':"/*0*/\n") (
- boring
--- )
- else if (sub_s == SLIT("NIL_")) then
--- trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
- Prel (WiredInVal nilDataCon)
--- )
- else if (sub_s == SLIT("TUP_")) then
--- trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
- Prel (WiredInVal (mkTupleCon arity))
--- )
- else
--- trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") (
- boring
--- )
- where
- boring = Unk s
- sub_s = _SUBSTR_ s 1 4 -- chars 1--4 (0-origin)
- arity = read (_UNPK_ (_SUBSTR_ s 5 999999))
- -- chars 5 onwards give the arity
-\end{code}
-
-\begin{code}
-wlkBasicLit :: U_literal -> UgnM BasicLit
-
-wlkBasicLit (U_norepr n d)
- = let
- num = ((read (_UNPK_ n)) :: Integer)
- den = ((read (_UNPK_ d)) :: Integer)
- in
- returnUgn (NoRepRational (num % den))
-
-wlkBasicLit other
- = returnUgn (
- case other of
- U_intprim s -> mkMachInt (as_integer s)
- U_doubleprim s -> MachDouble (as_rational s)
- U_floatprim s -> MachFloat (as_rational s)
- U_charprim s -> MachChar (as_char s)
- U_stringprim s -> MachStr (as_string s)
-
- U_clitlit s k -> MachLitLit (as_string s) (guessPrimKind (_UNPK_ k))
-
- U_norepi s -> NoRepInteger (as_integer s)
- U_noreps s -> NoRepStr (as_string s)
- )
- where
- as_char s = _HEAD_ s
- as_integer s = readInteger (_UNPK_ s)
- as_rational s = _readRational (_UNPK_ s) -- non-std
- as_string s = s
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
-interface ReadPrefix where
-import AbsSyn(Module)
-import HsDecls(ConDecl)
-import HsPat(InPat)
-import HsTypes(MonoType)
-import LiftMonad(LiftM)
-import ProtoName(ProtoName)
-rdConDecl :: [Char] -> [Char] -> LiftM (ConDecl ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _S_ "LS" _N_ _N_ #-}
-rdId :: [Char] -> LiftM (ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdIdString :: [Char] -> LiftM ([Char], [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdList :: ([Char] -> LiftM (a, [Char])) -> [Char] -> LiftM ([a], [Char])
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _S_ "LS" _N_ _N_ #-}
-rdModule :: [Char] -> ([Char], [Char] -> Bool, Module ProtoName (InPat ProtoName))
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-}
-rdMonoType :: [Char] -> LiftM (MonoType ProtoName, [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-rdString :: [Char] -> LiftM ([Char], [Char])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-}
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
-\section[ReadPrefix]{Read prefix-form input}
-
-This module contains a function, @rdModule@, which reads a Haskell
-module in `prefix form' emitted by the Lex/Yacc parser.
-
-The prefix form string is converted into an algebraic data type
-defined in @PrefixSyn@.
-
-Identifier names are converted into the @ProtoName@ data type.
-
-@sf@ is used consistently to mean ``source file'' (name).
+\section{Read parse tree built by Yacc parser}
\begin{code}
--- HBC does not have stack stubbing; you get a space leak w/
--- default defns from HsVersions.h.
-
--- GHC may be overly slow to compile w/ the defaults...
-
-#define BIND {--}
-#define _TO_ `thenLft` ( \ {--}
-#define BEND )
-#define RETN returnLft
-#define RETN_TYPE LiftM
-
#include "HsVersions.h"
-\end{code}
-\begin{code}
module ReadPrefix (
rdModule,
- rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType
- ) where
+ -- used over in ReadPragmas...
+ wlkList, wlkMaybe, rdConDecl, wlkMonoType, rdMonoType
+ ) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
+import Ubiq{-uitous-}
+import RdrLoop -- for paranoia checking
+
+import UgenAll -- all Yacc parser gumpff...
+import PrefixSyn -- and various syntaxen.
+import HsSyn
+import RdrHsSyn
-import AbsSyn
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import IdInfo ( UnfoldingGuidance(..) )
-import LiftMonad
-import Maybes ( Maybe(..) )
-import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
+-- friends:
import ReadPragmas
-import SrcLoc ( mkSrcLoc )
-import Util
+import PrefixToHs -- reader utilities
+
+-- others:
+import FiniteMap ( elemFM, FiniteMap )
+import MainMonad ( thenMn, MainIO(..) )
+import PprStyle ( PprStyle(..) )
+import Pretty
+import ProtoName ( isConopPN, ProtoName(..) )
+import Util ( nOfThem, panic )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rdList :: (String -> RETN_TYPE (a, String)) -> String -> RETN_TYPE ([a], String)
-
-rdList rd_it ('N':xs) = RETN ([], xs)
-rdList rd_it ('L':xs)
- = BIND (rd_it xs) _TO_ (hd_it, xs1) ->
- BIND (rdList rd_it xs1) _TO_ (tl_it, xs2) ->
- RETN (hd_it : tl_it, xs2)
- BEND BEND
-rdList rd_it junk = panic ("ReadPrefix.rdList:"++junk)
-
-rdString, rdIdString :: String -> RETN_TYPE (FAST_STRING, String)
-rdId :: String -> RETN_TYPE (ProtoName, String)
-
-rdString ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
- RETN (_PK_ (de_escape str), rest)
- BEND
- where
- -- partain: tabs and backslashes are escaped
- de_escape [] = []
- de_escape ('\\':'\\':xs) = '\\' : (de_escape xs)
- de_escape ('\\':'t':xs) = '\t' : (de_escape xs)
- de_escape (x:xs) = x : (de_escape xs)
-
-rdString xs = panic ("ReadPrefix.rdString:"++xs)
-
-rdIdString ('#':xs) = BIND (split_at_tab xs) _TO_ (stuff,rest) -> -- no de-escaping...
- RETN (_PK_ stuff, rest)
- BEND
-rdIdString other = panic ("rdIdString:"++other)
-
- -- no need to de-escape it...
-rdId ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
- RETN (Unk (_PK_ str), rest)
- BEND
-
-split_at_tab :: String -> RETN_TYPE (String, String) -- a la Lennart
-split_at_tab xs
- = split_me [] xs
- where
- split_me acc ('\t' : ys) = BIND (my_rev acc []) _TO_ reversed ->
- RETN (reversed, ys)
- BEND
- split_me acc (y : ys) = split_me (y:acc) ys
+wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
- my_rev "" acc = RETN acc -- instead of reverse, so can see on heap-profiles
- my_rev (x:xs) acc = my_rev xs (x:acc)
+wlkList wlk_it U_lnil = returnUgn []
+
+wlkList wlk_it (U_lcons hd tl)
+ = wlk_it hd `thenUgn` \ hd_it ->
+ wlkList wlk_it tl `thenUgn` \ tl_it ->
+ returnUgn (hd_it : tl_it)
+\end{code}
+
+\begin{code}
+wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
+
+wlkMaybe wlk_it U_nothing = returnUgn Nothing
+wlkMaybe wlk_it (U_just x)
+ = wlk_it x `thenUgn` \ it ->
+ returnUgn (Just it)
+\end{code}
+
+\begin{code}
+rdQid :: ParseTree -> UgnM ProtoName
+rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
+
+wlkQid :: U_qid -> UgnM ProtoName
+wlkQid (U_noqual name)
+ = returnUgn (Unk name)
+wlkQid (U_aqual mod name)
+ = returnUgn (Qunk mod name)
+wlkQid (U_gid n name)
+ = returnUgn (Unk name)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rdModule :: String
- -> (FAST_STRING, -- this module's name
- (FAST_STRING -> Bool, -- a function to chk if <x> is in the export list
- FAST_STRING -> Bool), -- a function to chk if <M> is among the M..
- -- ("dotdot") modules in the export list.
- ProtoNameModule) -- the main goods
-
-rdModule (next_char:xs)
- = case next_char of { 'M' ->
-
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdIdString xs1) _TO_ (name, xs2) ->
- BIND (rdString xs2) _TO_ (srcfile, xs3) ->
- BIND (rdBinding srcfile xs3) _TO_ (binding, xs4) ->
- BIND (rdList rdFixity xs4) _TO_ (fixities, xs5) ->
- BIND (rdList (rdImportedInterface srcfile) xs5) _TO_ (imports, xs6) ->
- BIND (rdList rdEntity xs6) _TO_ (export_list, _) ->
+rdModule :: MainIO
+ (FAST_STRING, -- this module's name
+ (FAST_STRING -> Bool, -- a function to chk if <x> is in the export list
+ FAST_STRING -> Bool), -- a function to chk if <M> is among the M..
+ -- ("dotdot") modules in the export list.
+ ProtoNameHsModule) -- the main goods
+
+rdModule
+ = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
+ let
+ srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM)
+ in
+ initUgn srcfile (
+
+ rdU_tree pt `thenUgn` \ (U_hmodule name himplist hexplist hfixlist hmodlist srcline) ->
+ wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
+ wlkBinding hmodlist `thenUgn` \ binding ->
+ wlkList rdImportedInterface himplist `thenUgn` \ imports ->
+ wlkMaybe rdEntities hexplist `thenUgn` \ exp_list ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
case sepDeclsForTopBinds binding of {
(tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
- (name,
- mk_export_list_chker export_list,
- Module name
- export_list
- imports
- fixities
- tydecls
- tysigs
- classdecls
- (cvInstDecls True name name instdecls) -- True indicates not imported
- instsigs
- defaultdecls
- (cvSepdBinds srcfile cvValSig binds)
- [{-no sigs-}]
- (mkSrcLoc srcfile srcline)
- )
- } BEND BEND BEND BEND BEND BEND BEND
- }
+ returnUgn (
+ name,
+ mk_export_list_chker exp_list,
+ HsModule name
+ exp_list
+ imports
+ fixities
+ tydecls
+ tysigs
+ classdecls
+ instdecls
+ instsigs
+ defaultdecls
+ (cvSepdBinds srcfile cvValSig binds)
+ [{-no sigs-}]
+ src_loc
+ ) } )
where
+ mk_export_list_chker = panic "ReadPrefix:mk_export_list_chker"
+{- LATER:
mk_export_list_chker exp_list
- = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) ->
- ( \ n -> n `elemFM` just_the_strings,
- \ n -> n `elemFM` dotdot_modules )
- }
+ = case (getExportees exp_list) of
+ Nothing -> ( \ n -> False, \ n -> False ) -- all suspicious
+ Just (entity_info, dotdot_modules) ->
+ ( \ n -> n `elemFM` entity_info,
+ \ n -> n `elemFM` dotdot_modules )
+-}
\end{code}
%************************************************************************
%* *
-\subsection[rdExprOrPat]{@rdExpr@ and @rdPat@}
+\subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
%* *
%************************************************************************
\begin{code}
-rdExpr :: SrcFile -> String -> RETN_TYPE (ProtoNameExpr, String)
-rdPat :: SrcFile -> String -> RETN_TYPE (ProtoNamePat, String)
-
-rdExpr sf (next_char:xs)
- = case next_char of
- '(' -> -- left section
- BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- BIND (rdId xs1) _TO_ (id, xs2) ->
- RETN (SectionL expr (Var id), xs2)
- BEND BEND
-
- ')' -> -- right section
- BIND (rdId xs) _TO_ (id, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr,xs2) ->
- RETN (SectionR (Var id) expr, xs2)
- BEND BEND
-
- 'j' -> -- ccall/casm
- BIND (rdString xs) _TO_ (fun, xs1) ->
- BIND (rdString xs1) _TO_ (flavor, xs2) ->
- BIND (rdList (rdExpr sf) xs2) _TO_ (args, xs3) ->
- RETN (CCall fun args
- (flavor == SLIT("p") || flavor == SLIT("P")) -- may invoke GC
- (flavor == SLIT("N") || flavor == SLIT("P")) -- really a "casm"
- (panic "CCall:result_ty"),
- xs3)
- BEND BEND BEND
-
- 'k' -> -- scc (set-cost-centre) expression
- BIND (rdString xs) _TO_ (label, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- RETN (SCC label expr, xs2)
- BEND BEND
-
- 'l' -> -- lambda expression
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdList (rdPat sf) xs1) _TO_ (pats, xs2) ->
- BIND (rdExpr sf xs2) _TO_ (body, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (Lam (foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn
- [OtherwiseGRHS body src_loc]
- EmptyBinds))
- pats
- ),
- xs3)
- BEND BEND BEND
-
- 'c' -> -- case expression
- BIND (rdExpr sf xs) _TO_ (expr, xs1) ->
- BIND (rdList (rdMatch sf) xs1) _TO_ (mats, xs2) ->
- let
- matches = cvMatches sf True mats
- in
- RETN (Case expr matches, xs2)
- BEND BEND
-
- 'b' -> -- if expression
- BIND (rdExpr sf xs) _TO_ (e1, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (e2, xs2) ->
- BIND (rdExpr sf xs2) _TO_ (e3, xs3) ->
- RETN (If e1 e2 e3, xs3)
- BEND BEND BEND
-
- 'E' -> -- let expression
- BIND (rdBinding sf xs) _TO_ (binding,xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- let
- binds = cvBinds sf cvValSig binding
- in
- RETN (Let binds expr, xs2)
- BEND BEND
-
- 'Z' -> -- list comprehension
- BIND (rdExpr sf xs) _TO_ (expr, xs1) ->
- BIND (rdList rd_qual xs1) _TO_ (quals, xs2) ->
- RETN (ListComp expr quals, xs2)
- BEND BEND
- where
- rd_qual ('G':xs)
- = BIND (rdPat sf xs) _TO_ (pat, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr,xs2) ->
- RETN (GeneratorQual pat expr, xs2)
- BEND BEND
-
- rd_qual ('g':xs)
- = BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- RETN (FilterQual expr, xs1)
- BEND
-
- '.' -> -- arithmetic sequence
- BIND (rdExpr sf xs) _TO_ (e1, xs1) ->
- BIND (rdList (rdExpr sf) xs1) _TO_ (es2, xs2) ->
- BIND (rdList (rdExpr sf) xs2) _TO_ (es3, xs3) ->
- RETN (cv_arith_seq e1 es2 es3, xs3)
- BEND BEND BEND
- where
- cv_arith_seq e1 [] [] = ArithSeqIn (From e1)
- cv_arith_seq e1 [] [e3] = ArithSeqIn (FromTo e1 e3)
- cv_arith_seq e1 [e2] [] = ArithSeqIn (FromThen e1 e2)
- cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3)
-
- 'R' -> -- expression with type signature
- BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- BIND (rdPolyType xs1) _TO_ (ty, xs2) ->
- RETN (ExprWithTySig expr ty, xs2)
- BEND BEND
-
- '-' -> -- negated expression
- BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- RETN (App (Var (Unk SLIT("negate"))) expr, xs1)
- BEND
-#ifdef DPH
- '5' -> -- parallel ZF expression
- BIND (rdExpr sf xs) _TO_ (expr, xs1) ->
- BIND (rdList (rd_par_qual sf) xs1) _TO_ (qual_list, xs2) ->
- let
- quals = foldr1 AndParQuals qual_list
- in
- RETN (RdrParallelZF expr quals, xs2)
- BEND BEND
- where
- rdParQual sf inp
- = case inp of
- -- ToDo:DPH: I have kawunkled your RdrExplicitProcessor hack
- '0':xs -> BIND (rdExPat sf xs) _TO_ (RdrExplicitProcessor pats pat, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- RETN (DrawnGenIn pats pat expr, xs2)
- BEND BEND
-
- 'w':xs -> BIND (rdExPat sf xs) _TO_ (RdrExplicitProcessor exprs pat, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- RETN (IndexGen exprs pat expr, xs2)
- BEND BEND
-
- 'I':xs -> BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- RETN (ParFilter expr, xs1)
- BEND
-
- '6' -> -- explicitPod expression
- BIND (rdList (rdExpr sf) xs) _TO_ (exprs,xs1) ->
- RETN (RdrExplicitPod exprs,xs1)
- BEND
-#endif {- Data Parallel Haskell -}
-
- --------------------------------------------------------------
- -- now the prefix items that can either be an expression or
- -- pattern, except we know they are *expressions* here
- -- (this code could be commoned up with the pattern version;
- -- but it probably isn't worth it)
- --------------------------------------------------------------
- 'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) ->
- RETN (Lit lit, xs1)
- BEND
-
- 'i' -> -- simple identifier
- BIND (rdId xs) _TO_ (str,xs1) ->
- RETN (Var str, xs1)
- BEND
-
- 'a' -> -- application
- BIND (rdExpr sf xs) _TO_ (expr1, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr2, xs2) ->
- RETN (App expr1 expr2, xs2)
- BEND BEND
-
- '@' -> -- operator application
- BIND (rdExpr sf xs) _TO_ (expr1, xs1) ->
- BIND (rdId xs1) _TO_ (op, xs2) ->
- BIND (rdExpr sf xs2) _TO_ (expr2, xs3) ->
- RETN (OpApp expr1 (Var op) expr2, xs3)
- BEND BEND BEND
-
- ':' -> -- explicit list
- BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
- RETN (ExplicitList exprs, xs1)
- BEND
-
- ',' -> -- explicit tuple
- BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
- RETN (ExplicitTuple exprs, xs1)
- BEND
-
-#ifdef DPH
- 'O' -> -- explicitProcessor expression
- BIND (rdList (rdExpr sf) xs) _TO_ (exprs,xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- RETN (ExplicitProcessor exprs expr, xs2)
- BEND BEND
-#endif {- Data Parallel Haskell -}
-
- huh -> panic ("ReadPrefix.rdExpr:"++(next_char:xs))
+rdExpr :: ParseTree -> UgnM ProtoNameHsExpr
+rdPat :: ParseTree -> UgnM ProtoNamePat
+
+rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
+rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
+
+wlkExpr :: U_tree -> UgnM ProtoNameHsExpr
+wlkPat :: U_tree -> UgnM ProtoNamePat
+
+wlkExpr expr
+ = case expr of
+ U_par expr -> -- parenthesised expr
+ wlkExpr expr
+
+ U_lsection lsexp lop -> -- left section
+ wlkExpr lsexp `thenUgn` \ expr ->
+ wlkQid lop `thenUgn` \ op ->
+ returnUgn (SectionL expr (HsVar op))
+
+ U_rsection rop rsexp -> -- right section
+ wlkQid rop `thenUgn` \ op ->
+ wlkExpr rsexp `thenUgn` \ expr ->
+ returnUgn (SectionR (HsVar op) expr)
+
+ U_ccall fun flavor ccargs -> -- ccall/casm
+ wlkList rdExpr ccargs `thenUgn` \ args ->
+ let
+ tag = _HEAD_ flavor
+ in
+ returnUgn (CCall fun args
+ (tag == 'p' || tag == 'P') -- may invoke GC
+ (tag == 'N' || tag == 'P') -- really a "casm"
+ (panic "CCall:result_ty"))
+
+ U_scc label sccexp -> -- scc (set-cost-centre) expression
+ wlkExpr sccexp `thenUgn` \ expr ->
+ returnUgn (HsSCC label expr)
+
+ U_lambda lampats lamexpr srcline -> -- lambda expression
+ wlkList rdPat lampats `thenUgn` \ pats ->
+ wlkExpr lamexpr `thenUgn` \ body ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (
+ HsLam (foldr PatMatch
+ (GRHSMatch (GRHSsAndBindsIn
+ [OtherwiseGRHS body src_loc]
+ EmptyBinds))
+ pats)
+ )
+
+ U_casee caseexpr casebody srcline -> -- case expression
+ wlkExpr caseexpr `thenUgn` \ expr ->
+ wlkList rdMatch casebody `thenUgn` \ mats ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ matches = cvMatches sf True mats
+ in
+ returnUgn (HsCase expr matches src_loc)
+
+ U_ife ifpred ifthen ifelse srcline -> -- if expression
+ wlkExpr ifpred `thenUgn` \ e1 ->
+ wlkExpr ifthen `thenUgn` \ e2 ->
+ wlkExpr ifelse `thenUgn` \ e3 ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (HsIf e1 e2 e3 src_loc)
+
+ U_let letvdefs letvexpr -> -- let expression
+ wlkBinding letvdefs `thenUgn` \ binding ->
+ wlkExpr letvexpr `thenUgn` \ expr ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ binds = cvBinds sf cvValSig binding
+ in
+ returnUgn (HsLet binds expr)
+
+ U_doe gdo srcline -> -- do expression
+ wlkList rd_stmt gdo `thenUgn` \ stmts ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (HsDo stmts src_loc)
+ where
+ rd_stmt pt
+ = rdU_tree pt `thenUgn` \ bind ->
+ case bind of
+ U_doexp exp srcline ->
+ wlkExpr exp `thenUgn` \ expr ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (ExprStmt expr src_loc)
+
+ U_dobind pat exp srcline ->
+ wlkPat pat `thenUgn` \ patt ->
+ wlkExpr exp `thenUgn` \ expr ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (BindStmt patt expr src_loc)
+
+ U_seqlet seqlet ->
+ wlkBinding seqlet `thenUgn` \ bs ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ binds = cvBinds sf cvValSig bs
+ in
+ returnUgn (LetStmt binds)
+
+ U_comprh cexp cquals -> -- list comprehension
+ wlkExpr cexp `thenUgn` \ expr ->
+ wlkList rd_qual cquals `thenUgn` \ quals ->
+ returnUgn (ListComp expr quals)
+ where
+ rd_qual pt
+ = rdU_tree pt `thenUgn` \ qual ->
+ wlk_qual qual
+
+ wlk_qual qual
+ = case qual of
+ U_guard exp ->
+ wlkExpr exp `thenUgn` \ expr ->
+ returnUgn (FilterQual expr)
+
+ U_qual qpat qexp ->
+ wlkPat qpat `thenUgn` \ pat ->
+ wlkExpr qexp `thenUgn` \ expr ->
+ returnUgn (GeneratorQual pat expr)
+
+ U_seqlet seqlet ->
+ wlkBinding seqlet `thenUgn` \ bs ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ binds = cvBinds sf cvValSig bs
+ in
+ returnUgn (LetQual binds)
+
+ U_eenum efrom estep eto -> -- arithmetic sequence
+ wlkExpr efrom `thenUgn` \ e1 ->
+ wlkMaybe rdExpr estep `thenUgn` \ es2 ->
+ wlkMaybe rdExpr eto `thenUgn` \ es3 ->
+ returnUgn (cv_arith_seq e1 es2 es3)
+ where
+ cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
+ cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
+ cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
+ cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
+
+ U_restr restre restrt -> -- expression with type signature
+ wlkExpr restre `thenUgn` \ expr ->
+ wlkPolyType restrt `thenUgn` \ ty ->
+ returnUgn (ExprWithTySig expr ty)
+
+ --------------------------------------------------------------
+ -- now the prefix items that can either be an expression or
+ -- pattern, except we know they are *expressions* here
+ -- (this code could be commoned up with the pattern version;
+ -- but it probably isn't worth it)
+ --------------------------------------------------------------
+ U_lit lit ->
+ wlkLiteral lit `thenUgn` \ lit ->
+ returnUgn (HsLit lit)
+
+ U_ident n -> -- simple identifier
+ wlkQid n `thenUgn` \ var ->
+ returnUgn (HsVar var)
+
+ U_ap fun arg -> -- application
+ wlkExpr fun `thenUgn` \ expr1 ->
+ wlkExpr arg `thenUgn` \ expr2 ->
+ returnUgn (HsApp expr1 expr2)
+
+ U_infixap fun arg1 arg2 -> -- infix application
+ wlkQid fun `thenUgn` \ op ->
+ wlkExpr arg1 `thenUgn` \ expr1 ->
+ wlkExpr arg2 `thenUgn` \ expr2 ->
+ returnUgn (OpApp expr1 (HsVar op) expr2)
+
+ U_negate nexp _ _ -> -- prefix negation
+ wlkExpr nexp `thenUgn` \ expr ->
+ returnUgn (HsApp (HsVar (Unk SLIT("negate"))) expr)
+
+ U_llist llist -> -- explicit list
+ wlkList rdExpr llist `thenUgn` \ exprs ->
+ returnUgn (ExplicitList exprs)
+
+ U_tuple tuplelist -> -- explicit tuple
+ wlkList rdExpr tuplelist `thenUgn` \ exprs ->
+ returnUgn (ExplicitTuple exprs)
+
+ U_record con rbinds -> -- record construction
+ wlkQid con `thenUgn` \ rcon ->
+ wlkList rdRbind rbinds `thenUgn` \ recbinds ->
+ returnUgn (RecordCon rcon recbinds)
+
+ U_rupdate updexp updbinds -> -- record update
+ wlkExpr updexp `thenUgn` \ aexp ->
+ wlkList rdRbind updbinds `thenUgn` \ recbinds ->
+ returnUgn (RecordUpd aexp recbinds)
+
+#ifdef DEBUG
+ U_hmodule _ _ _ _ _ _ -> error "U_hmodule"
+ U_as _ _ -> error "U_as"
+ U_lazyp _ -> error "U_lazyp"
+ U_wildp -> error "U_wildp"
+ U_qual _ _ -> error "U_qual"
+ U_guard _ -> error "U_guard"
+ U_seqlet _ -> error "U_seqlet"
+ U_dobind _ _ _ -> error "U_dobind"
+ U_doexp _ _ -> error "U_doexp"
+ U_rbind _ _ -> error "U_rbind"
+ U_fixop _ _ _ -> error "U_fixop"
+#endif
+
+rdRbind pt
+ = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
+ wlkQid var `thenUgn` \ rvar ->
+ wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
+ returnUgn (rvar, expr_maybe)
\end{code}
Patterns: just bear in mind that lists of patterns are represented as
a series of ``applications''.
\begin{code}
-rdPat sf (next_char:xs)
- = case next_char of
- 's' -> -- "as" pattern
- BIND (rdId xs) _TO_ (id, xs1) ->
- BIND (rdPat sf xs1) _TO_ (pat,xs2) ->
- RETN (AsPatIn id pat, xs2)
- BEND BEND
-
- '~' -> -- irrefutable ("twiddle") pattern
- BIND (rdPat sf xs) _TO_ (pat,xs1) ->
- RETN (LazyPatIn pat, xs1)
- BEND
-
- '+' -> -- n+k pattern
- BIND (rdPat sf xs) _TO_ (pat, xs1) ->
- BIND (rdLiteral xs1) _TO_ (lit, xs2) ->
- let
- n = case pat of
- VarPatIn n -> n
- WildPatIn -> error "ERROR: rdPat: GHC can't handle _+k patterns yet"
- in
- RETN (NPlusKPatIn n lit, xs2)
- BEND BEND
-
- '_' -> -- wildcard pattern
- RETN (WildPatIn, xs)
-
- --------------------------------------------------------------
- -- now the prefix items that can either be an expression or
- -- pattern, except we know they are *patterns* here.
- --------------------------------------------------------------
- '-' -> BIND (rdPat sf xs) _TO_ (lit_pat, xs1) ->
- case lit_pat of
- LitPatIn lit -> RETN (LitPatIn (negLiteral lit), xs1)
- _ -> panic "rdPat: bad negated pattern!"
- BEND
-
- 'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) ->
- RETN (LitPatIn lit, xs1)
- BEND
-
- 'i' -> -- simple identifier
- BIND (rdIdString xs) _TO_ (str, xs1) ->
- RETN (if isConop str then
- ConPatIn (Unk str) []
- else
- VarPatIn (Unk str),
- xs1)
- BEND
-
- 'a' -> -- "application": there's a list of patterns lurking here!
- BIND (rd_curried_pats xs) _TO_ (lpat:lpats, xs1) ->
- BIND (rdPat sf xs1) _TO_ (rpat, xs2) ->
- let
- (n, llpats)
- = case lpat of
- VarPatIn x -> (x, [])
- ConPatIn x [] -> (x, [])
- ConOpPatIn x op y -> (op, [x, y])
- other -> -- sorry about the weedy msg; the parser missed this one
- error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)]))
-
- arg_pats = llpats ++ lpats ++ [rpat]
- bad_app = (lpat:lpats) ++ [rpat]
- in
- RETN (ConPatIn n arg_pats, xs2)
- BEND BEND
- where
- rd_curried_pats ('a' : ys)
- = BIND (rd_curried_pats ys) _TO_ (lpats, ys1) ->
- BIND (rdPat sf ys1) _TO_ (rpat, ys2) ->
- RETN (lpats ++ [rpat], ys2)
- BEND BEND
- rd_curried_pats ys
- = BIND (rdPat sf ys) _TO_ (pat, ys1) ->
- RETN ([pat], ys1)
- BEND
-
- '@' -> -- operator application
- BIND (rdPat sf xs) _TO_ (pat1, xs1) ->
- BIND (rdId xs1) _TO_ (op, xs2) ->
- BIND (rdPat sf xs2) _TO_ (pat2, xs3) ->
- RETN (ConOpPatIn pat1 op pat2, xs3)
- BEND BEND BEND
-
- ':' -> -- explicit list
- BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
- RETN (ListPatIn pats, xs1)
- BEND
-
- ',' -> -- explicit tuple
- BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
- RETN (TuplePatIn pats, xs1)
- BEND
-
-#ifdef DPH
- 'O' -> -- explicitProcessor pattern
- BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
- BIND (rdPat sf xs1) _TO_ (pat, xs2) ->
- RETN (ProcessorPatIn pats pat, xs2)
- BEND BEND
-#endif {- Data Parallel Haskell -}
-
- huh -> panic ("ReadPrefix.rdPat:"++(next_char:xs))
+wlkPat pat
+ = case pat of
+ U_par pat -> -- parenthesised pattern
+ wlkPat pat
+
+ U_as avar as_pat -> -- "as" pattern
+ wlkQid avar `thenUgn` \ var ->
+ wlkPat as_pat `thenUgn` \ pat ->
+ returnUgn (AsPatIn var pat)
+
+ U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
+ wlkPat lazyp `thenUgn` \ pat ->
+ returnUgn (LazyPatIn pat)
+
+ U_wildp -> returnUgn WildPatIn -- wildcard pattern
+
+ --------------------------------------------------------------
+ -- now the prefix items that can either be an expression or
+ -- pattern, except we know they are *patterns* here.
+ --------------------------------------------------------------
+ U_negate nexp _ _ -> -- negated pattern: must be a literal
+ wlkPat nexp `thenUgn` \ lit_pat ->
+ case lit_pat of
+ LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit))
+ _ -> panic "wlkPat: bad negated pattern!"
+
+ U_lit lit -> -- literal pattern
+ wlkLiteral lit `thenUgn` \ lit ->
+ returnUgn (LitPatIn lit)
+
+ U_ident nn -> -- simple identifier
+ wlkQid nn `thenUgn` \ n ->
+ returnUgn (
+ if isConopPN n
+ then ConPatIn n []
+ else VarPatIn n
+ )
+
+ U_ap l r -> -- "application": there's a list of patterns lurking here!
+ wlkPat r `thenUgn` \ rpat ->
+ collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
+ let
+ (n, arg_pats)
+ = case lpat of
+ VarPatIn x -> (x, lpats)
+ ConPatIn x [] -> (x, lpats)
+ ConOpPatIn x op y -> (op, x:y:lpats)
+ _ -> -- sorry about the weedy msg; the parser missed this one
+ error (ppShow 100 (ppCat [
+ ppStr "ERROR: an illegal `application' of a pattern to another one:",
+ ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats))]))
+ in
+ returnUgn (ConPatIn n arg_pats)
+ where
+ collect_pats pat acc
+ = case pat of
+ U_ap l r ->
+ wlkPat r `thenUgn` \ rpat ->
+ collect_pats l (rpat:acc)
+ other ->
+ wlkPat other `thenUgn` \ pat ->
+ returnUgn (pat,acc)
+
+ U_infixap fun arg1 arg2 ->
+ wlkQid fun `thenUgn` \ op ->
+ wlkPat arg1 `thenUgn` \ pat1 ->
+ wlkPat arg2 `thenUgn` \ pat2 ->
+ returnUgn (ConOpPatIn pat1 op pat2)
+
+ U_llist llist -> -- explicit list
+ wlkList rdPat llist `thenUgn` \ pats ->
+ returnUgn (ListPatIn pats)
+
+ U_tuple tuplelist -> -- explicit tuple
+ wlkList rdPat tuplelist `thenUgn` \ pats ->
+ returnUgn (TuplePatIn pats)
+
+ U_record con rpats -> -- record destruction
+ wlkQid con `thenUgn` \ rcon ->
+ wlkList rdRpat rpats `thenUgn` \ recpats ->
+ returnUgn (RecPatIn rcon recpats)
+ where
+ rdRpat pt
+ = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
+ wlkQid var `thenUgn` \ rvar ->
+ wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
+ returnUgn (rvar, pat_maybe)
\end{code}
-OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that
-to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no
-expressions). Therefore in the pattern matching below we are taking
-this into consideration to create the @DrawGen@ whose fields are the
-\tr{K} patterns, pat and the exp right of the generator.
-
\begin{code}
-rdLiteral :: String -> RETN_TYPE (Literal, String)
-
-rdLiteral (tag : xs)
- = BIND (rdString xs) _TO_ (x, zs) ->
- let
- s = _UNPK_ x
-
- as_char = chr ((read s) :: Int)
- -- a char comes in as a number string
- -- representing its ASCII code
- as_integer = readInteger s
-#if __GLASGOW_HASKELL__ <= 22
- as_rational = toRational ((read s)::Double)
-#else
-#ifdef __GLASGOW_HASKELL__
- as_rational = _readRational s -- non-std
-#else
- as_rational = ((read s)::Rational)
-#endif
-#endif
- as_double = ((read s) :: Double)
- in
- case tag of {
- '4' -> RETN (IntLit as_integer, zs);
- 'F' -> RETN (FracLit as_rational, zs);
- 'H' -> RETN (IntPrimLit as_integer, zs);
-#if __GLASGOW_HASKELL__ <= 22
- 'J' -> RETN (DoublePrimLit as_double,zs);
- 'K' -> RETN (FloatPrimLit as_double, zs);
-#else
- 'J' -> RETN (DoublePrimLit as_rational,zs);
- 'K' -> RETN (FloatPrimLit as_rational, zs);
-#endif
- 'C' -> RETN (CharLit as_char, zs);
- 'P' -> RETN (CharPrimLit as_char, zs);
- 'S' -> RETN (StringLit x, zs);
- 'V' -> RETN (StringPrimLit x, zs);
- 'Y' -> RETN (LitLitLitIn x, zs)
- } BEND
+wlkLiteral :: U_literal -> UgnM HsLit
+
+wlkLiteral ulit
+ = returnUgn (
+ case ulit of
+ 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)
+ U_floatprim s -> HsFloatPrim (as_rational s)
+ U_charr s -> HsChar (as_char s)
+ U_charprim s -> HsCharPrim (as_char s)
+ U_string s -> HsString (as_string s)
+ U_stringprim s -> HsStringPrim (as_string s)
+ U_clitlit s _ -> HsLitLit (as_string s)
+ )
+ where
+ as_char s = _HEAD_ s
+ as_integer s = readInteger (_UNPK_ s)
+ as_rational s = _readRational (_UNPK_ s) -- non-std
+ as_string s = s
\end{code}
%************************************************************************
%* *
-\subsection[rdBinding]{rdBinding}
+\subsection{wlkBinding}
%* *
%************************************************************************
\begin{code}
-rdBinding :: SrcFile -> String -> RETN_TYPE (RdrBinding, String)
-
-rdBinding sf (next_char:xs)
- = case next_char of
- 'B' -> -- null binding
- RETN (RdrNullBind, xs)
-
- 'A' -> -- "and" binding (just glue, really)
- BIND (rdBinding sf xs) _TO_ (binding1, xs1) ->
- BIND (rdBinding sf xs1) _TO_ (binding2, xs2) ->
- RETN (RdrAndBindings binding1 binding2, xs2)
- BEND BEND
-
- 't' -> -- "data" declaration
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdContext xs1) _TO_ (ctxt, xs2) ->
- BIND (rdList rdId xs2) _TO_ (derivings, xs3) ->
- BIND (rdTyConAndTyVars xs3) _TO_ ((tycon, tyvars), xs4) ->
- BIND (rdList (rdConDecl sf) xs4) _TO_ (cons, xs5) ->
- BIND (rdDataPragma xs5) _TO_ (pragma, xs6) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc),
- xs6)
- BEND BEND BEND BEND BEND BEND
-
- 'n' -> -- "type" declaration
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdTyConAndTyVars xs1) _TO_ ((tycon, tyvars), xs2) ->
- BIND (rdMonoType xs2) _TO_ (expansion, xs3) ->
- BIND (rdTypePragma xs3) _TO_ (pragma, xs4) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc),
- xs4)
- BEND BEND BEND BEND
-
- 'f' -> -- function binding
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) ->
- RETN (RdrFunctionBinding (read (_UNPK_ srcline)) matches, xs2)
- BEND BEND
-
- 'p' -> -- pattern binding
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) ->
- RETN (RdrPatternBinding (read (_UNPK_ srcline)) matches, xs2)
- BEND BEND
-
- '$' -> -- "class" declaration
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdContext xs1) _TO_ (ctxt, xs2) ->
- BIND (rdClassAssertTy xs2) _TO_ ((clas, tyvar), xs3) ->
- BIND (rdBinding sf xs3) _TO_ (binding, xs4) ->
- BIND (rdClassPragma xs4) _TO_ (pragma, xs5) ->
- let
- (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
-
- final_sigs = concat (map cvClassOpSig class_sigs)
- final_methods = cvMonoBinds sf class_methods
-
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrClassDecl
- (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc),
- xs5)
- BEND BEND BEND BEND BEND
-
- '%' -> -- "instance" declaration
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdContext xs1) _TO_ (ctxt, xs2) ->
- BIND (rdId xs2) _TO_ (clas, xs3) ->
- BIND (rdMonoType xs3) _TO_ (inst_ty, xs4) ->
- BIND (rdBinding sf xs4) _TO_ (binding, xs5) ->
- BIND (rdInstPragma xs5) _TO_ (modname_maybe, pragma, xs6) ->
- let
- (ss, bs) = sepDeclsIntoSigsAndBinds binding
- binds = cvMonoBinds sf bs
- uprags = concat (map cvInstDeclSig ss)
- src_loc = mkSrcLoc sf srcline
- in
- case modname_maybe of {
- Nothing ->
- RETN (RdrInstDecl (\ orig_mod infor_mod here ->
- InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
- xs6);
- Just orig_mod ->
- RETN (RdrInstDecl (\ _ infor_mod here ->
- InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
- xs6)
- }
- BEND BEND BEND BEND BEND BEND
-
- 'D' -> -- "default" declaration
- BIND (rdString xs) _TO_ (srcline,xs1) ->
- BIND (rdList rdMonoType xs1) _TO_ (tys, xs2) ->
-
- RETN (RdrDefaultDecl (DefaultDecl tys (mkSrcLoc sf srcline)),
- xs2)
- BEND BEND
-
- '7' -> -- "import" declaration in an interface
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdIdString xs1) _TO_ (mod, xs2) ->
- BIND (rdList rdEntity xs2) _TO_ (entities, xs3) ->
- BIND (rdList rdRenaming xs3) _TO_ (renamings, xs4) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc),
- xs4)
- BEND BEND BEND BEND
-
- 'S' -> -- signature(-like) things, including user pragmas
- rd_sig_thing sf xs
+wlkBinding :: U_binding -> UgnM RdrBinding
+
+wlkBinding binding
+ = case binding of
+ U_nullbind -> -- null binding
+ returnUgn RdrNullBind
+
+ U_abind a b -> -- "and" binding (just glue, really)
+ wlkBinding a `thenUgn` \ binding1 ->
+ wlkBinding b `thenUgn` \ binding2 ->
+ returnUgn (RdrAndBindings binding1 binding2)
+
+ U_tbind tctxt ttype tcons tderivs srcline tpragma -> -- "data" declaration
+ wlkContext tctxt `thenUgn` \ ctxt ->
+ wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
+ wlkList rdConDecl tcons `thenUgn` \ cons ->
+ wlkDerivings tderivs `thenUgn` \ derivings ->
+ wlkDataPragma tpragma `thenUgn` \ pragmas ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings pragmas src_loc))
+
+ U_ntbind ntctxt nttype ntcon ntderivs srcline ntpragma -> -- "newtype" declaration
+ wlkContext ntctxt `thenUgn` \ ctxt ->
+ wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
+ wlkList rdConDecl ntcon `thenUgn` \ con ->
+ wlkDerivings ntderivs `thenUgn` \ derivings ->
+ wlkDataPragma ntpragma `thenUgn` \ pragma ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings pragma src_loc))
+
+ U_nbind nbindid nbindas srcline -> -- "type" declaration
+ wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
+ wlkMonoType nbindas `thenUgn` \ expansion ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
+
+ U_fbind fbindl srcline -> -- function binding
+ wlkList rdMatch fbindl `thenUgn` \ matches ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrFunctionBinding srcline matches)
+
+ U_pbind pbindl srcline -> -- pattern binding
+ wlkList rdMatch pbindl `thenUgn` \ matches ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrPatternBinding srcline matches)
+
+ U_cbind cbindc cbindid cbindw srcline cpragma -> -- "class" declaration
+ wlkContext cbindc `thenUgn` \ ctxt ->
+ wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
+ wlkBinding cbindw `thenUgn` \ binding ->
+ wlkClassPragma cpragma `thenUgn` \ pragma ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
+
+ final_sigs = concat (map cvClassOpSig class_sigs)
+ final_methods = cvMonoBinds sf class_methods
+ in
+ returnUgn (RdrClassDecl
+ (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc))
+
+ U_ibind from_source orig_mod -- "instance" declaration
+ ibindc iclas ibindi ibindw srcline ipragma ->
+ wlkContext ibindc `thenUgn` \ ctxt ->
+ wlkQid iclas `thenUgn` \ clas ->
+ wlkMonoType ibindi `thenUgn` \ inst_ty ->
+ wlkBinding ibindw `thenUgn` \ binding ->
+ wlkInstPragma ipragma `thenUgn` \ pragma ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ from_here = case from_source of { 0 -> False; 1 -> True }
+ (ss, bs) = sepDeclsIntoSigsAndBinds binding
+ binds = cvMonoBinds sf bs
+ uprags = concat (map cvInstDeclSig ss)
+ ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
+ in
+ returnUgn (RdrInstDecl
+ (InstDecl clas ctxt_inst_ty binds from_here orig_mod uprags pragma src_loc))
+
+ U_dbind dbindts srcline -> -- "default" declaration
+ wlkList rdMonoType dbindts `thenUgn` \ tys ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
+
+ U_mbind mod mbindimp srcline ->
+ -- "import" declaration in an interface
+ wlkList rdEntity mbindimp `thenUgn` \ entities ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities src_loc))
+
+ U_mfbind fixes ->
+ -- "infix" declarations in an interface
+ wlkList rdFixOp fixes `thenUgn` \ fixities ->
+ returnUgn (RdrIfaceFixities fixities)
+
+ a_sig_we_hope ->
+ -- signature(-like) things, including user pragmas
+ wlk_sig_thing a_sig_we_hope
+\end{code}
+
+\begin{code}
+wlkDerivings :: U_maybe -> UgnM (Maybe [ProtoName])
+
+wlkDerivings (U_nothing) = returnUgn Nothing
+wlkDerivings (U_just pt)
+ = rdU_list pt `thenUgn` \ ds ->
+ wlkList rdQid ds `thenUgn` \ derivs ->
+ returnUgn (Just derivs)
\end{code}
\begin{code}
-rd_sig_thing sf (next_char:xs)
- = case next_char of
- 't' -> -- type signature
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdList rdId xs1) _TO_ (vars, xs2) ->
- BIND (rdPolyType xs2) _TO_ (poly_ty, xs3) ->
- BIND (rdTySigPragmas xs3) _TO_ (pragma, xs4) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrTySig vars poly_ty pragma src_loc, xs4)
- BEND BEND BEND BEND
-
- 's' -> -- value specialisation user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (var, xs2) ->
- BIND (rdList rdPolyType xs2) _TO_ (tys, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrSpecValSig [SpecSig var ty Nothing{-ToDo: using...s-} src_loc | ty <- tys], xs3)
- BEND BEND BEND
-
- 'S' -> -- instance specialisation user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (clas, xs2) ->
- BIND (rdMonoType xs2) _TO_ (ty, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrSpecInstSig (InstSpecSig clas ty src_loc), xs3)
- BEND BEND BEND
-
- 'i' -> -- value inlining user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (var, xs2) ->
- BIND (rdList rdIdString xs2) _TO_ (howto, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
-
- guidance
- = (case howto of {
- [] -> id;
- [x] -> trace "ignoring unfold howto" }) UnfoldAlways
- in
- RETN (RdrInlineValSig (InlineSig var guidance src_loc), xs3)
- BEND BEND BEND
-
- 'd' -> -- value deforest user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (var, xs2) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrDeforestSig (DeforestSig var src_loc), xs2)
- BEND BEND
-
- 'u' -> -- value magic-unfolding user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (var, xs2) ->
- BIND (rdIdString xs2) _TO_ (str, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc), xs3)
- BEND BEND BEND
-
- 'a' -> -- abstract-type-synonym user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (tycon, xs2) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc), xs2)
- BEND BEND
-
- 'd' -> -- data specialisation user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (tycon, xs2) ->
- BIND (rdList rdMonoType xs2) _TO_ (tys, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- spec_ty = MonoTyCon tycon tys
- in
- RETN (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc), xs3)
- BEND BEND BEND
+wlk_sig_thing (U_sbind sbindids sbindid srcline spragma) -- type signature
+ = wlkList rdQid sbindids `thenUgn` \ vars ->
+ wlkPolyType sbindid `thenUgn` \ poly_ty ->
+ wlkTySigPragmas spragma `thenUgn` \ pragma ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrTySig vars poly_ty pragma src_loc)
+
+wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) -- value specialisation user-pragma
+ = wlkQid uvar `thenUgn` \ var ->
+ wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
+ | (ty, using_id) <- tys_and_ids ])
+ where
+ rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName)
+ rd_ty_and_id pt
+ = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
+ wlkPolyType vspec_ty `thenUgn` \ ty ->
+ wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe ->
+ returnUgn(ty, id_maybe)
+
+wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)-- instance specialisation user-pragma
+ = wlkQid iclas `thenUgn` \ clas ->
+ wlkMonoType ispec_ty `thenUgn` \ ty ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
+
+wlk_sig_thing (U_inline_uprag ivar srcline) -- value inlining user-pragma
+ = wlkQid ivar `thenUgn` \ var ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrInlineValSig (InlineSig var src_loc))
+
+wlk_sig_thing (U_deforest_uprag ivar srcline) -- "deforest me" user-pragma
+ = wlkQid ivar `thenUgn` \ var ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrDeforestSig (DeforestSig var src_loc))
+
+wlk_sig_thing (U_magicuf_uprag ivar str srcline) -- "magic" unfolding user-pragma
+ = wlkQid ivar `thenUgn` \ var ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
+
+wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
+ = wlkQid itycon `thenUgn` \ tycon ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
+ let
+ spec_ty = MonoTyApp tycon tys
+ in
+ returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc))
\end{code}
%************************************************************************
%* *
-\subsection[rdTypes]{Reading in types in various forms (and data constructors)}
+\subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
%* *
%************************************************************************
\begin{code}
-rdPolyType :: String -> RETN_TYPE (ProtoNamePolyType, String)
-rdMonoType :: String -> RETN_TYPE (ProtoNameMonoType, String)
-
-rdPolyType ('3' : xs)
- = BIND (rdContext xs) _TO_ (ctxt, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (OverloadedTy ctxt ty, xs2)
- BEND BEND
-
-rdPolyType ('2' : 'C' : xs)
- = BIND (rdList rdId xs) _TO_ (tvs, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (ForAllTy tvs ty, xs2)
- BEND BEND
-
-rdPolyType other
- = BIND (rdMonoType other) _TO_ (ty, xs1) ->
- RETN (UnoverloadedTy ty, xs1)
- BEND
-
-rdMonoType ('T' : xs)
- = BIND (rdId xs) _TO_ (tycon, xs1) ->
- BIND (rdList rdMonoType xs1) _TO_ (tys, xs2) ->
- RETN (MonoTyCon tycon tys, xs2)
- BEND BEND
-
-rdMonoType (':' : xs)
- = BIND (rdMonoType xs) _TO_ (ty, xs1) ->
- RETN (ListMonoTy ty, xs1)
- BEND
-
-rdMonoType (',' : xs)
- = BIND (rdList rdPolyType xs) _TO_ (tys, xs1) ->
- RETN (TupleMonoTy tys, xs1)
- BEND
-
-rdMonoType ('>' : xs)
- = BIND (rdMonoType xs) _TO_ (ty1, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty2, xs2) ->
- RETN (FunMonoTy ty1 ty2, xs2)
- BEND BEND
-
-rdMonoType ('y' : xs)
- = BIND (rdId xs) _TO_ (tyvar, xs1) ->
- RETN (MonoTyVar tyvar, xs1)
- BEND
-
-rdMonoType ('2' : 'A' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (MonoDict clas ty, xs2)
- BEND BEND
-
-rdMonoType ('2' : 'B' : xs)
- = BIND (rdId xs) _TO_ (tv_tmpl, xs1) ->
- RETN (MonoTyVarTemplate tv_tmpl, xs1)
- BEND
-
-#ifdef DPH
-rdMonoType ('v' : xs)
- = BIND (rdMonoType xs) _TO_ (ty, xs1) ->
- RETN (RdrExplicitPodTy ty, xs1)
- BEND
-
-rdMonoType ('u' : xs)
- = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (RdrExplicitProcessorTy tys ty, xs2)
- BEND BEND
-#endif {- Data Parallel Haskell -}
-
-rdMonoType oops = panic ("rdMonoType:"++oops)
+rdPolyType :: ParseTree -> UgnM ProtoNamePolyType
+rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
+
+rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
+rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
+
+wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType
+wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
+
+wlkPolyType ttype
+ = case ttype of
+{-LATER:
+ U_uniforall utvs uty -> -- forall type (pragmas)
+ wlkList rdU_unkId utvs `thenUgn` \ tvs ->
+ wlkMonoType uty `thenUgn` \ ty ->
+ returnUgn (HsForAllTy tvs ty)
+-}
+
+ U_context tcontextl tcontextt -> -- context
+ wlkContext tcontextl `thenUgn` \ ctxt ->
+ wlkMonoType tcontextt `thenUgn` \ ty ->
+ returnUgn (HsPreForAllTy ctxt ty)
+
+ other -> -- something else
+ wlkMonoType other `thenUgn` \ ty ->
+ returnUgn (HsPreForAllTy [{-no context-}] ty)
+
+wlkMonoType ttype
+ = case ttype of
+ U_namedtvar tyvar -> -- type variable
+ returnUgn (MonoTyVar tyvar)
+
+ U_tname tcon -> -- type constructor
+ wlkQid tcon `thenUgn` \ tycon ->
+ returnUgn (MonoTyApp tycon [])
+
+ U_tapp t1 t2 ->
+ wlkMonoType t2 `thenUgn` \ ty2 ->
+ collect t1 [ty2] `thenUgn` \ (tycon, tys) ->
+ returnUgn (MonoTyApp tycon tys)
+ where
+ collect t acc
+ = case t of
+ U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
+ collect t1 (ty2:acc)
+ U_tname tcon -> wlkQid tcon `thenUgn` \ tycon ->
+ returnUgn (tycon, acc)
+ U_namedtvar tv -> returnUgn (tv, acc)
+ U_tllist _ -> panic "tlist"
+ U_ttuple _ -> panic "ttuple"
+ U_tfun _ _ -> panic "tfun"
+ U_tbang _ -> panic "tbang"
+ U_context _ _ -> panic "context"
+ _ -> panic "something else"
+
+ U_tllist tlist -> -- list type
+ wlkMonoType tlist `thenUgn` \ ty ->
+ returnUgn (MonoListTy ty)
+
+ U_ttuple ttuple ->
+ wlkList rdMonoType ttuple `thenUgn` \ tys ->
+ returnUgn (MonoTupleTy tys)
+
+ U_tfun tfun targ ->
+ wlkMonoType tfun `thenUgn` \ ty1 ->
+ wlkMonoType targ `thenUgn` \ ty2 ->
+ returnUgn (MonoFunTy ty1 ty2)
+
+ U_unidict uclas t -> -- DictTy (pragmas)
+ wlkQid uclas `thenUgn` \ clas ->
+ wlkMonoType t `thenUgn` \ ty ->
+ returnUgn (MonoDictTy clas ty)
\end{code}
\begin{code}
-rdTyConAndTyVars :: String -> RETN_TYPE ((ProtoName, [ProtoName]), String)
-rdContext :: String -> RETN_TYPE (ProtoNameContext, String)
-rdClassAssertTy :: String -> RETN_TYPE ((ProtoName, ProtoName), String)
+wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName])
+wlkContext :: U_list -> UgnM ProtoNameContext
+wlkClassAssertTy :: U_ttype -> UgnM (ProtoName, ProtoName)
-rdTyConAndTyVars xs
- = BIND (rdMonoType xs) _TO_ (MonoTyCon tycon ty_args, xs1) ->
+wlkTyConAndTyVars ttype
+ = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
let
args = [ a | (MonoTyVar a) <- ty_args ]
in
- RETN ((tycon, args), xs1)
- BEND
+ returnUgn (tycon, args)
-rdContext xs
- = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
- RETN (map mk_class_assertion tys, xs1)
- BEND
+wlkContext list
+ = wlkList rdMonoType list `thenUgn` \ tys ->
+ returnUgn (map mk_class_assertion tys)
-rdClassAssertTy xs
- = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) ->
- RETN (mk_class_assertion mono_ty, xs1)
- BEND
+wlkClassAssertTy xs
+ = wlkMonoType xs `thenUgn` \ mono_ty ->
+ returnUgn (mk_class_assertion mono_ty)
mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
-mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname)
+mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
mk_class_assertion other
= error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
-- regrettably, the parser does let some junk past
\end{code}
\begin{code}
-rdConDecl :: SrcFile -> String -> RETN_TYPE (ProtoNameConDecl, String)
-
-rdConDecl sf ('1':xs)
- = BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (id, xs2) ->
- BIND (rdList rdMonoType xs2) _TO_ (tys, xs3) ->
- RETN (ConDecl id tys (mkSrcLoc sf srcline), xs3)
- BEND BEND BEND
+rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
+rdConDecl pt
+ = rdU_constr pt `thenUgn` \ blah ->
+ wlkConDecl blah
+
+wlkConDecl :: U_constr -> UgnM ProtoNameConDecl
+
+wlkConDecl (U_constrpre ccon ctys srcline)
+ = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ wlkQid ccon `thenUgn` \ con ->
+ wlkList rdBangType ctys `thenUgn` \ tys ->
+ returnUgn (ConDecl con tys src_loc)
+
+wlkConDecl (U_constrinf cty1 cop cty2 srcline)
+ = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ wlkBangType cty1 `thenUgn` \ ty1 ->
+ wlkQid cop `thenUgn` \ op ->
+ wlkBangType cty2 `thenUgn` \ ty2 ->
+ returnUgn (ConOpDecl ty1 op ty2 src_loc)
+
+wlkConDecl (U_constrnew ccon cty srcline)
+ = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ wlkQid ccon `thenUgn` \ con ->
+ wlkMonoType cty `thenUgn` \ ty ->
+ returnUgn (NewConDecl con ty src_loc)
+
+wlkConDecl (U_constrrec ccon cfields srcline)
+ = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ wlkQid ccon `thenUgn` \ con ->
+ wlkList rd_field cfields `thenUgn` \ fields_lists ->
+ returnUgn (RecConDecl con (concat fields_lists) src_loc)
+ where
+ rd_field :: ParseTree -> UgnM [(ProtoName, BangType ProtoName)]
+ rd_field pt
+ = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
+ wlkList rdQid fvars `thenUgn` \ vars ->
+ wlkBangType fty `thenUgn` \ ty ->
+ returnUgn [ (var, ty) | var <- vars ]
+
+-----------------
+rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
+
+wlkBangType :: U_ttype -> UgnM (BangType ProtoName)
+
+wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged ty)
+wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
+
\end{code}
%************************************************************************
%* *
-\subsection[rdMatch]{Read a ``match''}
+\subsection{Read a ``match''}
%* *
%************************************************************************
\begin{code}
-rdMatch :: SrcFile -> String -> RETN_TYPE (RdrMatch, String)
+rdMatch :: ParseTree -> UgnM RdrMatch
-rdMatch sf ('W':xs)
- = BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdIdString xs1) _TO_ (srcfun, xs2) ->
- BIND (rdPat sf xs2) _TO_ (pat, xs3) ->
- BIND (rdList rd_guarded xs3) _TO_ (grhss, xs4) ->
- BIND (rdBinding sf xs4) _TO_ (binding, xs5) ->
+rdMatch pt
+ = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
+
+ wlkPat gpat `thenUgn` \ pat ->
+ wlkBinding gbind `thenUgn` \ binding ->
+ wlkQid gsrcfun `thenUgn` \ srcfun ->
+ let
+ wlk_guards (U_pnoguards exp)
+ = wlkExpr exp `thenUgn` \ expr ->
+ returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
- RETN (RdrMatch (read (_UNPK_ srcline)) srcfun pat grhss binding, xs5)
- BEND BEND BEND BEND BEND
+ wlk_guards (U_pguards gs)
+ = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
+ returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
+ in
+ wlk_guards gdexprs
where
- rd_guarded xs
- = BIND (rdExpr sf xs) _TO_ (g, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (e, xs2) ->
- RETN ((g, e), xs2)
- BEND BEND
+ rd_gd_expr pt
+ = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
+ wlkExpr g `thenUgn` \ guard ->
+ wlkExpr e `thenUgn` \ expr ->
+ returnUgn (guard, expr)
\end{code}
%************************************************************************
%* *
-\subsection[rdFixity]{Read in a fixity declaration}
+\subsection[rdFixOp]{Read in a fixity declaration}
%* *
%************************************************************************
\begin{code}
-rdFixity :: String -> RETN_TYPE (ProtoNameFixityDecl, String)
-rdFixity xs
- = BIND (rdId xs) _TO_ (op, xs1) ->
- BIND (rdString xs1) _TO_ (associativity, xs2) ->
- BIND (rdString xs2) _TO_ (prec_str, xs3) ->
- let
- precedence = read (_UNPK_ prec_str)
- in
- case (_UNPK_ associativity) of {
- "infix" -> RETN (InfixN op precedence, xs3);
- "infixl" -> RETN (InfixL op precedence, xs3);
- "infixr" -> RETN (InfixR op precedence, xs3)
- } BEND BEND BEND
+rdFixOp :: ParseTree -> UgnM ProtoNameFixityDecl
+rdFixOp pt
+ = rdU_tree pt `thenUgn` \ fix ->
+ case fix of
+ U_fixop op (-1) prec -> returnUgn (InfixL op prec)
+ U_fixop op 0 prec -> returnUgn (InfixN op prec)
+ U_fixop op 1 prec -> returnUgn (InfixR op prec)
+ _ -> error "ReadPrefix:rdFixOp"
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rdImportedInterface :: FAST_STRING -> String
- -> RETN_TYPE (ProtoNameImportedInterface, String)
+rdImportedInterface :: ParseTree
+ -> UgnM ProtoNameImportedInterface
+
+rdImportedInterface pt
+ = rdU_binding pt
+ `thenUgn` \ (U_import ifname iffile binddef imod iqual ias ispec srcline) ->
-rdImportedInterface importing_srcfile (x:xs)
- = BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdString xs1) _TO_ (srcfile, xs2) ->
- BIND (rdIdString xs2) _TO_ (modname, xs3) ->
- BIND (rdList rdEntity xs3) _TO_ (imports, xs4) ->
- BIND (rdList rdRenaming xs4) _TO_ (renamings,xs5) ->
- BIND (rdBinding srcfile xs5) _TO_ (iface_bs, xs6) ->
+ mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
+ wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
+
+ setSrcFileUgn iffile ( -- looking inside the .hi file...
+ wlkBinding binddef
+ ) `thenUgn` \ iface_bs ->
case (sepDeclsForInterface iface_bs) of {
- (tydecls,classdecls,instdecls,sigs,iimpdecls) ->
+ (tydecls,classdecls,instdecls,sigs,iimpdecls,ifixities) ->
let
- expose_or_hide = case x of { 'e' -> ImportSome; 'h' -> ImportButHide }
-
- cv_iface
- = MkInterface modname
- iimpdecls
- [{-fixity decls-}] -- can't get fixity decls in here yet (ToDo)
- tydecls
- classdecls
- (cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-}
- modname instdecls)
- -- False indicates imported
- (concat (map cvValSig sigs))
- (mkSrcLoc importing_srcfile srcline)
- in
- RETN (
- (if null imports then
- ImportAll cv_iface renamings
- else
- expose_or_hide cv_iface imports renamings
- , xs6))
- } BEND BEND BEND BEND BEND BEND
-\end{code}
+ cv_sigs = concat (map cvValSig sigs)
-\begin{code}
-rdRenaming :: String -> RETN_TYPE (Renaming, String)
+ cv_iface = Interface ifname iimpdecls ifixities
+ tydecls classdecls instdecls cv_sigs
+ src_loc
-rdRenaming xs
- = BIND (rdIdString xs) _TO_ (id1, xs1) ->
- BIND (rdIdString xs1) _TO_ (id2, xs2) ->
- RETN (MkRenaming id1 id2, xs2)
- BEND BEND
+ cv_qual = case iqual of {0 -> False; 1 -> True}
+ in
+ returnUgn (ImportMod cv_iface cv_qual maybe_as maybe_spec)
+ }
+ where
+ rd_spec pt = rdU_either pt `thenUgn` \ spec ->
+ case spec of
+ U_left pt -> rdEntities pt `thenUgn` \ ents ->
+ returnUgn (False, ents)
+ U_right pt -> rdEntities pt `thenUgn` \ ents ->
+ returnUgn (True, ents)
\end{code}
\begin{code}
-rdEntity :: String -> RETN_TYPE (IE, String)
-
-rdEntity inp
- = case inp of
- 'x':xs -> BIND (rdIdString xs) _TO_ (var, xs1) ->
- RETN (IEVar var, xs1)
- BEND
-
- 'X':xs -> BIND (rdIdString xs) _TO_ (thing, xs1) ->
- RETN (IEThingAbs thing, xs1)
- BEND
-
- 'z':xs -> BIND (rdIdString xs) _TO_ (thing, xs1) ->
- RETN (IEThingAll thing, xs1)
- BEND
-
- '8':xs -> BIND (rdIdString xs) _TO_ (tycon, xs1) ->
- BIND (rdList rdString xs1) _TO_ (cons, xs2) ->
- RETN (IEConWithCons tycon cons, xs2)
- BEND BEND
-
- '9':xs -> BIND (rdIdString xs) _TO_ (c, xs1) ->
- BIND (rdList rdString xs1) _TO_ (ops, xs2) ->
- RETN (IEClsWithOps c ops, xs2)
- BEND BEND
-
- 'm':xs -> BIND (rdIdString xs) _TO_ (m, xs1) ->
- RETN (IEModuleContents m, xs1)
- BEND
+rdEntities pt
+ = rdU_list pt `thenUgn` \ list ->
+ wlkList rdEntity list
+
+rdEntity :: ParseTree -> UgnM (IE ProtoName)
+
+rdEntity pt
+ = rdU_entidt pt `thenUgn` \ entity ->
+ case entity of
+ U_entid evar -> -- just a value
+ wlkQid evar `thenUgn` \ var ->
+ returnUgn (IEVar var)
+
+ U_enttype x -> -- abstract type constructor/class
+ wlkQid x `thenUgn` \ thing ->
+ returnUgn (IEThingAbs thing)
+
+ U_enttypeall x -> -- non-abstract type constructor/class
+ wlkQid x `thenUgn` \ thing ->
+ returnUgn (IEThingAll thing)
+
+ U_enttypenamed x ns -> -- non-abstract type constructor/class
+ -- with specified constrs/methods
+ wlkQid x `thenUgn` \ thing ->
+ wlkList rdQid ns `thenUgn` \ names ->
+ returnUgn (IEThingAll thing)
+ -- returnUgn (IEThingWith thing names)
+
+ U_entmod mod -> -- everything provided by a module
+ returnUgn (IEModuleContents mod)
\end{code}
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ReadPrefix2 where
-import AbsSyn(Module)
-import HsDecls(ConDecl)
-import HsPat(InPat)
-import HsTypes(MonoType)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-import U_list(U_list)
-import U_ttype(U_ttype)
-rdConDecl :: _Addr -> _PackedString -> _State _RealWorld -> (ConDecl ProtoName, _State _RealWorld)
-rdModule :: _State _RealWorld -> ((_PackedString, (_PackedString -> Bool, _PackedString -> Bool), Module ProtoName (InPat ProtoName)), _State _RealWorld)
-wlkList :: (_Addr -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> U_list -> _PackedString -> _State _RealWorld -> ([a], _State _RealWorld)
-wlkMonoType :: U_ttype -> _PackedString -> _State _RealWorld -> (MonoType ProtoName, _State _RealWorld)
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[ReadPrefix2]{Read parse tree built by Yacc parser}
-
-Comments?
-
-\begin{code}
-#include "HsVersions.h"
-
-module ReadPrefix2 (
- rdModule,
-
- -- used over in ReadPragmas2...
- wlkList, rdConDecl, wlkMonoType
- ) where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-
-import UgenAll
-
-import AbsSyn
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import FiniteMap
-import IdInfo ( UnfoldingGuidance(..) )
-import MainMonad
-import Maybes ( Maybe(..) )
-import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
-import ReadPragmas2
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ReadPrefix-help]{Help Functions}
-%* *
-%************************************************************************
-
-\begin{code}
-wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
-
-wlkList wlk_it U_lnil = returnUgn []
-
-wlkList wlk_it (U_lcons hd tl)
- = wlk_it hd `thenUgn` \ hd_it ->
- wlkList wlk_it tl `thenUgn` \ tl_it ->
- returnUgn (hd_it : tl_it)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[rdModule]{@rdModule@: reads in a Haskell module}
-%* *
-%************************************************************************
-
-\begin{code}
-rdModule :: MainIO
- (FAST_STRING, -- this module's name
- (FAST_STRING -> Bool, -- a function to chk if <x> is in the export list
- FAST_STRING -> Bool), -- a function to chk if <M> is among the M..
- -- ("dotdot") modules in the export list.
- ProtoNameModule) -- the main goods
-
-rdModule
- = _ccall_ hspmain `thenMn` \ pt -> -- call the Yacc parser!
- let
- srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM)
- in
- initUgn srcfile (
-
- rdU_tree pt `thenUgn` \ (U_hmodule name himplist hexplist hmodlist srcline) ->
- rdFixities `thenUgn` \ fixities ->
- wlkBinding hmodlist `thenUgn` \ binding ->
- wlkList rdImportedInterface himplist `thenUgn` \ imports ->
- wlkList rdEntity hexplist `thenUgn` \ export_list->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
-
- case sepDeclsForTopBinds binding of {
- (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
- -- ToDo: bad for laziness??
-
- returnUgn (
- name,
- mk_export_list_chker export_list,
- Module name
- export_list
- imports
- fixities
- tydecls
- tysigs
- classdecls
- (cvInstDecls True name name instdecls) -- True indicates not imported
- instsigs
- defaultdecls
- (cvSepdBinds srcfile cvValSig binds)
- [{-no sigs-}]
- src_loc
- ) } )
- where
- mk_export_list_chker exp_list
- = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) ->
- ( \ n -> n `elemFM` entity_info,
- \ n -> n `elemFM` dotdot_modules )
- }
-\end{code}
-
-Convert fixities table:
-\begin{code}
-rdFixities :: UgnM [ProtoNameFixityDecl]
-
-rdFixities
- = ioToUgnM (_ccall_ nfixes) `thenUgn` \ num_fixities@(I# _) ->
- let
- rd i acc
- | i >= num_fixities
- = returnUgn acc
-
- | otherwise
- = ioToUgnM (_ccall_ fixtype i) `thenUgn` \ fix_ty@(A# _) ->
- if fix_ty == ``NULL'' then
- rd (i+1) acc
- else
- ioToUgnM (_ccall_ fixop i) `thenUgn` \ fix_op@(A# _) ->
- ioToUgnM (_ccall_ precedence i) `thenUgn` \ precedence@(I# _) ->
- let
- op = Unk (_packCString fix_op)
-
- associativity
- = _UNPK_ (_packCString fix_ty)
-
- new_fix
- = case associativity of
- "infix" -> InfixN op precedence
- "infixl" -> InfixL op precedence
- "infixr" -> InfixR op precedence
- in
- rd (i+1) (new_fix : acc)
- in
- rd 0 []
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
-%* *
-%************************************************************************
-
-\begin{code}
-rdExpr :: ParseTree -> UgnM ProtoNameExpr
-rdPat :: ParseTree -> UgnM ProtoNamePat
-
-rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
-rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
-
-wlkExpr :: U_tree -> UgnM ProtoNameExpr
-wlkPat :: U_tree -> UgnM ProtoNamePat
-
-wlkExpr expr
- = case expr of
- U_par expr -> -- parenthesised expr
- wlkExpr expr
-
- U_lsection lsexp op -> -- left section
- wlkExpr lsexp `thenUgn` \ expr ->
- returnUgn (SectionL expr (Var op))
-
- U_rsection op rsexp -> -- right section
- wlkExpr rsexp `thenUgn` \ expr ->
- returnUgn (SectionR (Var op) expr)
-
- U_ccall fun flavor ccargs -> -- ccall/casm
- wlkList rdExpr ccargs `thenUgn` \ args ->
- let
- tag = _HEAD_ flavor
- in
- returnUgn (CCall fun args
- (tag == 'p' || tag == 'P') -- may invoke GC
- (tag == 'N' || tag == 'P') -- really a "casm"
- (panic "CCall:result_ty"))
-
- U_scc label sccexp -> -- scc (set-cost-centre) expression
- wlkExpr sccexp `thenUgn` \ expr ->
- returnUgn (SCC label expr)
-
- U_lambda lampats lamexpr srcline -> -- lambda expression
- wlkList rdPat lampats `thenUgn` \ pats ->
- wlkExpr lamexpr `thenUgn` \ body ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (
- Lam (foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn
- [OtherwiseGRHS body src_loc]
- EmptyBinds))
- pats)
- )
-
- U_casee caseexpr casebody -> -- case expression
- wlkExpr caseexpr `thenUgn` \ expr ->
- wlkList rdMatch casebody `thenUgn` \ mats ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- matches = cvMatches sf True mats
- in
- returnUgn (Case expr matches)
-
- U_ife ifpred ifthen ifelse -> -- if expression
- wlkExpr ifpred `thenUgn` \ e1 ->
- wlkExpr ifthen `thenUgn` \ e2 ->
- wlkExpr ifelse `thenUgn` \ e3 ->
- returnUgn (If e1 e2 e3)
-
- U_let letvdeflist letvexpr -> -- let expression
- wlkBinding letvdeflist `thenUgn` \ binding ->
- wlkExpr letvexpr `thenUgn` \ expr ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- binds = cvBinds sf cvValSig binding
- in
- returnUgn (Let binds expr)
-
- U_comprh cexp cquals -> -- list comprehension
- wlkExpr cexp `thenUgn` \ expr ->
- wlkList rd_qual cquals `thenUgn` \ quals ->
- returnUgn (ListComp expr quals)
- where
- rd_qual pt
- = rdU_tree pt `thenUgn` \ qual ->
- wlk_qual qual
-
- wlk_qual qual
- = case qual of
- U_par expr -> wlk_qual expr -- overkill? (ToDo?)
-
- U_qual qpat qexp ->
- wlkPat qpat `thenUgn` \ pat ->
- wlkExpr qexp `thenUgn` \ expr ->
- returnUgn (GeneratorQual pat expr)
-
- U_guard gexp ->
- wlkExpr gexp `thenUgn` \ expr ->
- returnUgn (FilterQual expr)
-
- U_eenum efrom estep eto -> -- arithmetic sequence
- wlkExpr efrom `thenUgn` \ e1 ->
- wlkList rdExpr estep `thenUgn` \ es2 ->
- wlkList rdExpr eto `thenUgn` \ es3 ->
- returnUgn (cv_arith_seq e1 es2 es3)
- where -- ToDo: use Maybe type
- cv_arith_seq e1 [] [] = ArithSeqIn (From e1)
- cv_arith_seq e1 [] [e3] = ArithSeqIn (FromTo e1 e3)
- cv_arith_seq e1 [e2] [] = ArithSeqIn (FromThen e1 e2)
- cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3)
-
- U_restr restre restrt -> -- expression with type signature
- wlkExpr restre `thenUgn` \ expr ->
- wlkPolyType restrt `thenUgn` \ ty ->
- returnUgn (ExprWithTySig expr ty)
-
- U_negate nexp -> -- negated expression
- wlkExpr nexp `thenUgn` \ expr ->
- returnUgn (App (Var (Unk SLIT("negate"))) expr)
-
- -- ToDo: DPH stuff
-
- --------------------------------------------------------------
- -- now the prefix items that can either be an expression or
- -- pattern, except we know they are *expressions* here
- -- (this code could be commoned up with the pattern version;
- -- but it probably isn't worth it)
- --------------------------------------------------------------
- U_lit lit ->
- wlkLiteral lit `thenUgn` \ lit ->
- returnUgn (Lit lit)
-
- U_ident n -> -- simple identifier
- returnUgn (Var n)
-
- U_ap fun arg -> -- application
- wlkExpr fun `thenUgn` \ expr1 ->
- wlkExpr arg `thenUgn` \ expr2 ->
- returnUgn (App expr1 expr2)
-
- U_tinfixop (op, arg1, arg2) ->
- wlkExpr arg1 `thenUgn` \ expr1 ->
- wlkExpr arg2 `thenUgn` \ expr2 ->
- returnUgn (OpApp expr1 (Var op) expr2)
-
- U_llist llist -> -- explicit list
- wlkList rdExpr llist `thenUgn` \ exprs ->
- returnUgn (ExplicitList exprs)
-
- U_tuple tuplelist -> -- explicit tuple
- wlkList rdExpr tuplelist `thenUgn` \ exprs ->
- returnUgn (ExplicitTuple exprs)
-
-#ifdef DEBUG
- U_hmodule _ _ _ _ _ -> error "U_hmodule"
- U_as _ _ -> error "U_as"
- U_lazyp _ -> error "U_lazyp"
- U_plusp _ _ -> error "U_plusp"
- U_wildp -> error "U_wildp"
- U_qual _ _ -> error "U_qual"
- U_guard _ -> error "U_guard"
- U_def _ -> error "U_def"
-#endif
-
--- ToDo: DPH stuff
-\end{code}
-
-Patterns: just bear in mind that lists of patterns are represented as
-a series of ``applications''.
-\begin{code}
-wlkPat pat
- = case pat of
- U_par pat -> -- parenthesised pattern
- wlkPat pat
-
- U_as var as_pat -> -- "as" pattern
- wlkPat as_pat `thenUgn` \ pat ->
- returnUgn (AsPatIn var pat)
-
- U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
- wlkPat lazyp `thenUgn` \ pat ->
- returnUgn (LazyPatIn pat)
-
- U_plusp plusn plusk -> -- n+k pattern
- wlkPat plusn `thenUgn` \ pat ->
- wlkLiteral plusk `thenUgn` \ lit ->
- let
- n = case pat of
- VarPatIn n -> n
- WildPatIn -> error "ERROR: wlkPat: GHC can't handle _+k patterns\n"
- in
- returnUgn (NPlusKPatIn n lit)
-
- U_wildp -> returnUgn WildPatIn -- wildcard pattern
-
- --------------------------------------------------------------
- -- now the prefix items that can either be an expression or
- -- pattern, except we know they are *patterns* here.
- --------------------------------------------------------------
- U_negate nexp -> -- negated pattern: negatee must be a literal
- wlkPat nexp `thenUgn` \ lit_pat ->
- case lit_pat of
- LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit))
- _ -> panic "wlkPat: bad negated pattern!"
-
- U_lit lit ->
- wlkLiteral lit `thenUgn` \ lit ->
- returnUgn (LitPatIn lit)
-
- U_ident n -> -- simple identifier
- returnUgn (
- if isConopPN n
- then ConPatIn n []
- else VarPatIn n
- )
-
- U_ap l r -> -- "application": there's a list of patterns lurking here!
- wlk_curried_pats l `thenUgn` \ (lpat:lpats) ->
- wlkPat r `thenUgn` \ rpat ->
- let
- (n, llpats)
- = case lpat of
- VarPatIn x -> (x, [])
- ConPatIn x [] -> (x, [])
- ConOpPatIn x op y -> (op, [x, y])
- _ -> -- sorry about the weedy msg; the parser missed this one
- error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)]))
-
- arg_pats = llpats ++ lpats ++ [rpat]
- bad_app = (lpat:lpats) ++ [rpat]
- in
- returnUgn (ConPatIn n arg_pats)
- where
- wlk_curried_pats pat
- = case pat of
- U_ap l r ->
- wlk_curried_pats l `thenUgn` \ lpats ->
- wlkPat r `thenUgn` \ rpat ->
- returnUgn (lpats ++ [rpat])
- other ->
- wlkPat other `thenUgn` \ pat ->
- returnUgn [pat]
-
- U_tinfixop (op, arg1, arg2) ->
- wlkPat arg1 `thenUgn` \ pat1 ->
- wlkPat arg2 `thenUgn` \ pat2 ->
- returnUgn (ConOpPatIn pat1 op pat2)
-
- U_llist llist -> -- explicit list
- wlkList rdPat llist `thenUgn` \ pats ->
- returnUgn (ListPatIn pats)
-
- U_tuple tuplelist -> -- explicit tuple
- wlkList rdPat tuplelist `thenUgn` \ pats ->
- returnUgn (TuplePatIn pats)
-
- -- ToDo: DPH
-\end{code}
-
-OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that
-to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no
-expressions). Therefore in the pattern matching below we are taking
-this into consideration to create the @DrawGen@ whose fields are the
-\tr{K} patterns, pat and the exp right of the generator.
-
-\begin{code}
-wlkLiteral :: U_literal -> UgnM Literal
-
-wlkLiteral ulit
- = returnUgn (
- case ulit of
- U_integer s -> IntLit (as_integer s)
- U_floatr s -> FracLit (as_rational s)
- U_intprim s -> IntPrimLit (as_integer s)
- U_doubleprim s -> DoublePrimLit (as_rational s)
- U_floatprim s -> FloatPrimLit (as_rational s)
- U_charr s -> CharLit (as_char s)
- U_charprim s -> CharPrimLit (as_char s)
- U_string s -> StringLit (as_string s)
- U_stringprim s -> StringPrimLit (as_string s)
- U_clitlit s _ -> LitLitLitIn (as_string s)
- )
- where
- as_char s = _HEAD_ s
- as_integer s = readInteger (_UNPK_ s)
- as_rational s = _readRational (_UNPK_ s) -- non-std
- as_string s = s
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{wlkBinding}
-%* *
-%************************************************************************
-
-\begin{code}
-wlkBinding :: U_binding -> UgnM RdrBinding
-
-wlkBinding binding
- = case binding of
- U_nullbind -> -- null binding
- returnUgn RdrNullBind
-
- U_abind a b -> -- "and" binding (just glue, really)
- wlkBinding a `thenUgn` \ binding1 ->
- wlkBinding b `thenUgn` \ binding2 ->
- returnUgn (RdrAndBindings binding1 binding2)
-
- U_tbind tbindc tbindid tbindl tbindd srcline tpragma -> -- "data" declaration
- wlkContext tbindc `thenUgn` \ ctxt ->
- wlkList rdU_unkId tbindd `thenUgn` \ derivings ->
- wlkTyConAndTyVars tbindid `thenUgn` \ (tycon, tyvars) ->
- wlkList rdConDecl tbindl `thenUgn` \ cons ->
- wlkDataPragma tpragma `thenUgn` \ pragma ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc))
-
- U_nbind nbindid nbindas srcline npragma -> -- "type" declaration
- wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
- wlkMonoType nbindas `thenUgn` \ expansion ->
- wlkTypePragma npragma `thenUgn` \ pragma ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc))
-
- U_fbind fbindl srcline -> -- function binding
- wlkList rdMatch fbindl `thenUgn` \ matches ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrFunctionBinding srcline matches)
-
- U_pbind pbindl srcline -> -- pattern binding
- wlkList rdMatch pbindl `thenUgn` \ matches ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrPatternBinding srcline matches)
-
- U_cbind cbindc cbindid cbindw srcline cpragma -> -- "class" declaration
- wlkContext cbindc `thenUgn` \ ctxt ->
- wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar) ->
- wlkBinding cbindw `thenUgn` \ binding ->
- wlkClassPragma cpragma `thenUgn` \ pragma ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
-
- final_sigs = concat (map cvClassOpSig class_sigs)
- final_methods = cvMonoBinds sf class_methods
- in
- returnUgn (RdrClassDecl
- (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc))
-
- U_ibind ibindc clas ibindi ibindw srcline ipragma -> -- "instance" declaration
- wlkContext ibindc `thenUgn` \ ctxt ->
- wlkMonoType ibindi `thenUgn` \ inst_ty ->
- wlkBinding ibindw `thenUgn` \ binding ->
- wlkInstPragma ipragma `thenUgn` \ (modname_maybe, pragma) ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- (ss, bs) = sepDeclsIntoSigsAndBinds binding
- binds = cvMonoBinds sf bs
- uprags = concat (map cvInstDeclSig ss)
- in
- returnUgn (
- case modname_maybe of {
- Nothing ->
- RdrInstDecl (\ orig_mod infor_mod here ->
- InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc);
- Just orig_mod ->
- RdrInstDecl (\ _ infor_mod here ->
- InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc)
- })
-
- U_dbind dbindts srcline -> -- "default" declaration
- wlkList rdMonoType dbindts `thenUgn` \ tys ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
-
- U_mbind mod mbindimp mbindren srcline ->
- -- "import" declaration in an interface
- wlkList rdEntity mbindimp `thenUgn` \ entities ->
- wlkList rdRenaming mbindren `thenUgn` \ renamings ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc))
-
- a_sig_we_hope ->
- -- signature(-like) things, including user pragmas
- wlk_sig_thing a_sig_we_hope
-\end{code}
-
-ToDo: really needed as separate?
-\begin{code}
-wlk_sig_thing (U_sbind sbindids sbindid srcline spragma) -- type signature
- = wlkList rdU_unkId sbindids `thenUgn` \ vars ->
- wlkPolyType sbindid `thenUgn` \ poly_ty ->
- wlkTySigPragmas spragma `thenUgn` \ pragma ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrTySig vars poly_ty pragma src_loc)
-
-wlk_sig_thing (U_vspec_uprag var vspec_tys srcline) -- value specialisation user-pragma
- = wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
- | (ty, using_id) <- tys_and_ids ])
- where
- rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName)
- rd_ty_and_id pt
- = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
- wlkPolyType vspec_ty `thenUgn` \ ty ->
- wlkList rdU_unkId vspec_id `thenUgn` \ id_list ->
- returnUgn(ty, case id_list of { [] -> Nothing; [x] -> Just x })
-
-wlk_sig_thing (U_ispec_uprag clas ispec_ty srcline)-- instance specialisation user-pragma
- = wlkMonoType ispec_ty `thenUgn` \ ty ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrSpecInstSig (InstSpecSig clas ty src_loc))
-
-wlk_sig_thing (U_inline_uprag var inline_howto srcline) -- value inlining user-pragma
- = wlkList rdU_stringId inline_howto `thenUgn` \ howto ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- let
- guidance -- ToDo: use Maybe type
- = (case howto of {
- [] -> id;
- [x] -> trace "ignoring unfold howto" }) UnfoldAlways
- in
- returnUgn (RdrInlineValSig (InlineSig var guidance src_loc))
-
-wlk_sig_thing (U_deforest_uprag var srcline) -- "deforest me" user-pragma
- = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrDeforestSig (DeforestSig var src_loc))
-
-wlk_sig_thing (U_magicuf_uprag var str srcline) -- "magic" unfolding user-pragma
- = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
-
-wlk_sig_thing (U_abstract_uprag tycon srcline) -- abstract-type-synonym user-pragma
- = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc))
-
-wlk_sig_thing (U_dspec_uprag tycon dspec_tys srcline)
- = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
- let
- spec_ty = MonoTyCon tycon tys
- in
- returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
-%* *
-%************************************************************************
-
-\begin{code}
-rdPolyType :: ParseTree -> UgnM ProtoNamePolyType
-rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
-
-rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
-rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
-
-wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType
-wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
-
-wlkPolyType ttype
- = case ttype of
- U_context tcontextl tcontextt -> -- context
- wlkContext tcontextl `thenUgn` \ ctxt ->
- wlkMonoType tcontextt `thenUgn` \ ty ->
- returnUgn (OverloadedTy ctxt ty)
-
- U_uniforall utvs uty -> -- forall type (pragmas)
- wlkList rdU_unkId utvs `thenUgn` \ tvs ->
- wlkMonoType uty `thenUgn` \ ty ->
- returnUgn (ForAllTy tvs ty)
-
- other -> -- something else
- wlkMonoType other `thenUgn` \ ty ->
- returnUgn (UnoverloadedTy ty)
-
-wlkMonoType ttype
- = case ttype of
- U_tname tycon typel -> -- tycon
- wlkList rdMonoType typel `thenUgn` \ tys ->
- returnUgn (MonoTyCon tycon tys)
-
- U_tllist tlist -> -- list type
- wlkMonoType tlist `thenUgn` \ ty ->
- returnUgn (ListMonoTy ty)
-
- U_ttuple ttuple ->
- wlkList rdPolyType ttuple `thenUgn` \ tys ->
- returnUgn (TupleMonoTy tys)
-
- U_tfun tfun targ ->
- wlkMonoType tfun `thenUgn` \ ty1 ->
- wlkMonoType targ `thenUgn` \ ty2 ->
- returnUgn (FunMonoTy ty1 ty2)
-
- U_namedtvar tyvar -> -- type variable
- returnUgn (MonoTyVar tyvar)
-
- U_unidict clas t -> -- UniDict (pragmas)
- wlkMonoType t `thenUgn` \ ty ->
- returnUgn (MonoDict clas ty)
-
- U_unityvartemplate tv_tmpl -> -- pragmas only
- returnUgn (MonoTyVarTemplate tv_tmpl)
-
-#ifdef DPH
-wlkMonoType ('v' : xs)
- = wlkMonoType xs `thenUgn` \ (ty, xs1) ->
- returnUgn (RdrExplicitPodTy ty, xs1)
- BEND
-
-wlkMonoType ('u' : xs)
- = wlkList rdMonoType xs `thenUgn` \ (tys, xs1) ->
- wlkMonoType xs1 `thenUgn` \ (ty, xs2) ->
- returnUgn (RdrExplicitProcessorTy tys ty, xs2)
- BEND BEND
-#endif {- Data Parallel Haskell -}
-
---wlkMonoType oops = panic ("wlkMonoType:"++oops)
-\end{code}
-
-\begin{code}
-wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName])
-wlkContext :: U_list -> UgnM ProtoNameContext
-wlkClassAssertTy :: U_ttype -> UgnM (ProtoName, ProtoName)
-
-wlkTyConAndTyVars ttype
- = wlkMonoType ttype `thenUgn` \ (MonoTyCon tycon ty_args) ->
- let
- args = [ a | (MonoTyVar a) <- ty_args ]
- in
- returnUgn (tycon, args)
-
-wlkContext list
- = wlkList rdMonoType list `thenUgn` \ tys ->
- returnUgn (map mk_class_assertion tys)
-
-wlkClassAssertTy xs
- = wlkMonoType xs `thenUgn` \ mono_ty ->
- returnUgn (mk_class_assertion mono_ty)
-
-mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
-
-mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname)
-mk_class_assertion other
- = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
- -- regrettably, the parser does let some junk past
- -- e.g., f :: Num {-nothing-} => a -> ...
-\end{code}
-
-\begin{code}
-rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
-
-rdConDecl pt
- = rdU_atype pt `thenUgn` \ (U_atc con atctypel srcline) ->
-
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- wlkList rdMonoType atctypel `thenUgn` \ tys ->
- returnUgn (ConDecl con tys src_loc)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Read a ``match''}
-%* *
-%************************************************************************
-
-\begin{code}
-rdMatch :: ParseTree -> UgnM RdrMatch
-
-rdMatch pt
- = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind srcfun srcline) ->
-
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- wlkPat gpat `thenUgn` \ pat ->
- wlkList rd_guarded gdexprs `thenUgn` \ grhss ->
- wlkBinding gbind `thenUgn` \ binding ->
-
- returnUgn (RdrMatch srcline srcfun pat grhss binding)
- where
- rd_guarded pt
- = rdU_list pt `thenUgn` \ list ->
- wlkList rdExpr list `thenUgn` \ [g,e] ->
- returnUgn (g, e)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[wlkFixity]{Read in a fixity declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-{-
-wlkFixity :: ParseTree -> UgnM ProtoNameFixityDecl
-
-wlkFixity pt
- = wlkId xs `thenUgn` \ (op, xs1) ->
- wlkIdString xs1 `thenUgn` \ (associativity, xs2) ->
- wlkIdString xs2 `thenUgn` \ (prec_str, xs3) ->
- let
- precedence = read prec_str
- in
- case associativity of {
- "infix" -> returnUgn (InfixN op precedence, xs3);
- "infixl" -> returnUgn (InfixL op precedence, xs3);
- "infixr" -> returnUgn (InfixR op precedence, xs3)
- } BEND BEND BEND
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[rdImportedInterface]{Read an imported interface}
-%* *
-%************************************************************************
-
-\begin{code}
-rdImportedInterface :: ParseTree
- -> UgnM ProtoNameImportedInterface
-
-rdImportedInterface pt
- = grab_pieces pt `thenUgn`
- \ (expose_or_hide,
- modname,
- bindexp,
- bindren,
- binddef,
- bindfile,
- srcline) ->
-
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- wlkList rdEntity bindexp `thenUgn` \ imports ->
- wlkList rdRenaming bindren `thenUgn` \ renamings ->
-
- setSrcFileUgn bindfile ( -- OK, we're now looking inside the .hi file...
- wlkBinding binddef
- ) `thenUgn` \ iface_bs ->
-
- case (sepDeclsForInterface iface_bs) of {
- (tydecls,classdecls,instdecls,sigs,iimpdecls) ->
- let
- cv_iface
- = MkInterface modname
- iimpdecls
- [{-fixity decls-}] -- can't get fixity decls in here yet (ToDo)
- tydecls
- classdecls
- (cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-}
- modname instdecls)
- -- False indicates imported
- (concat (map cvValSig sigs))
- src_loc -- OLD: (mkSrcLoc importing_srcfile srcline)
- in
- returnUgn (
- if null imports then
- ImportAll cv_iface renamings
- else
- expose_or_hide cv_iface imports renamings
- )}
- where
- grab_pieces pt
- = rdU_binding pt `thenUgn` \ binding ->
- returnUgn (
- case binding of
- U_import a b c d e f -> (ImportSome, a, b, c, d, e, f)
- U_hiding a b c d e f -> (ImportButHide, a, b, c, d, e, f)
- )
-\end{code}
-
-\begin{code}
-rdRenaming :: ParseTree -> UgnM Renaming
-
-rdRenaming pt
- = rdU_list pt `thenUgn` \ list ->
- wlkList rdU_stringId list `thenUgn` \ [id1, id2] ->
- returnUgn (MkRenaming id1 id2)
-\end{code}
-
-\begin{code}
-rdEntity :: ParseTree -> UgnM IE
-
-rdEntity pt
- = rdU_entidt pt `thenUgn` \ entity ->
- case entity of
- U_entid var -> -- just a value
- returnUgn (IEVar var)
-
- U_enttype thing -> -- abstract type constructor/class
- returnUgn (IEThingAbs thing)
-
- U_enttypeall thing -> -- non-abstract type constructor/class
- returnUgn (IEThingAll thing)
-
- U_enttypecons tycon ctentcons -> -- type con w/ data cons listed
- wlkList rdU_stringId ctentcons `thenUgn` \ cons ->
- returnUgn (IEConWithCons tycon cons)
-
- U_entclass clas centops -> -- class with ops listed
- wlkList rdU_stringId centops `thenUgn` \ ops ->
- returnUgn (IEClsWithOps clas ops)
-
- U_entmod mod -> -- everything provided by a module
- returnUgn (IEModuleContents mod)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename where
-import AbsSyn(Module)
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..), RenamedPat(..))
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..), PreludeNameFun(..), PreludeNameFuns(..))
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import Unique(Unique)
-data Module a b
-data Bag a
-data GlobalSwitch
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data InPat a
-type ProtoNamePat = InPat ProtoName
-type RenamedPat = InPat Name
-data Labda a
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-type GlobalNameFun = ProtoName -> Labda Name
-type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
-type PreludeNameFun = _PackedString -> Labda Name
-type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-data SplitUniqSupply
-renameModule :: (GlobalSwitch -> Bool) -> (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Module ProtoName (InPat ProtoName) -> SplitUniqSupply -> (Module Name (InPat Name), [_PackedString], (ProtoName -> Labda Name, ProtoName -> Labda Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
%
-% (c) The GRASP Project, Glasgow University, 1992-1994
+% (c) The GRASP Project, Glasgow University, 1992-1996
%
\section[Rename]{Renaming and dependency analysis passes}
\begin{code}
#include "HsVersions.h"
-module Rename (
- renameModule,
-
- -- for completeness
- Module, Bag, InPat, ProtoNamePat(..), RenamedPat(..), Name,
- ProtoName, SplitUniqSupply, PreludeNameFun(..),
- PreludeNameFuns(..), Maybe, Error(..), Pretty(..), PprStyle,
- PrettyRep, GlobalNameFuns(..), GlobalNameFun(..),
- GlobalSwitch
- ) where
-
-import AbsSyn
-import Bag ( isEmptyBag, unionBags, Bag )
-import CmdLineOpts ( GlobalSwitch(..) )
-import RenameMonad12
-import Rename1
-import Rename2
-import Rename3
-import Rename4
-import RenameAuxFuns ( PreludeNameFuns(..), GlobalNameFuns(..) )
---import Pretty -- ToDo: rm debugging
-import SplitUniq ( splitUniqSupply, SplitUniqSupply )
-import Util
+module Rename ( renameModule ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn
+import RdrHsSyn ( ProtoNameHsModule(..) )
+import RnHsSyn ( RenamedHsModule(..) )
+
+import Bag ( isEmptyBag, unionBags )
+import CmdLineOpts ( opt_UseGetMentionedVars )
+import ErrUtils ( Error(..) )
+import Pretty ( Pretty(..){-ToDo:rm?-} )
+import RnMonad12 ( initRn12 )
+import RnMonad4 ( initRn4 )
+import RnPass1
+import RnPass2
+import RnPass3
+import RnPass4
+import RnUtils ( PreludeNameMappers(..), GlobalNameMappers(..) )
+import UniqSupply ( splitUniqSupply )
+import Util ( panic )
\end{code}
Here's what the renamer does, basically:
\begin{description}
-\item[@Rename1@:]
+\item[@RnPass1@:]
Flattens out the declarations from the interfaces which this module
imports. The result is a new module with no imports, but with more
declarations. (Obviously, the imported declarations have ``funny
import, renaming, \& such.
%--------------------------------------------------------------------
-\item[@Rename2@:]
+\item[@RnPass2@:]
Removes duplicate declarations. Duplicates can arise when two
imported interface have a signature (or whatever) for the same
thing. We check that the two are consistent and then drop one.
pragmatic information.
%--------------------------------------------------------------------
-\item[@Rename3@:]
+\item[@RnPass3@:]
Find all the top-level-ish (i.e., global) entities, assign them
@Uniques@, and make a \tr{ProtoName -> Name} mapping for them,
in preparation for...
%--------------------------------------------------------------------
-\item[@Rename4@:]
+\item[@RnPass4@:]
Actually prepare the ``renamed'' module. In sticking @Names@ on
everything, it will catch out-of-scope errors (and a couple of similar
type-variable-use errors). We also our initial dependency analysis of
\end{description}
\begin{code}
-renameModule :: (GlobalSwitch -> Bool) -- to check cmd-line opts
- -> PreludeNameFuns -- lookup funs for deeply wired-in names
- -> ProtoNameModule -- input
- -> SplitUniqSupply
- -> (RenamedModule, -- output, after renaming
- [FAST_STRING], -- Names of the imported modules
+renameModule :: PreludeNameMappers -- lookup funs for deeply wired-in names
+ -> ProtoNameHsModule -- input
+ -> UniqSupply
+ -> (RenamedHsModule, -- output, after renaming
+ Bag FAST_STRING, -- Names of the imported modules
-- (profiling needs to know this)
- GlobalNameFuns, -- final name funs; used later
+ GlobalNameMappers, -- final name funs; used later
-- to rename generated `deriving'
-- bindings.
Bag Error -- Errors, from passes 1-4
-- Very space-leak sensitive
-renameModule sw_chkr gnfs@(val_pnf, tc_pnf)
- input@(Module mod_name _ _ _ _ _ _ _ _ _ _ _ _)
+renameModule gnfs@(val_pnf, tc_pnf)
+ input@(HsModule mod_name _ _ _ _ _ _ _ _ _ _ _ _)
uniqs
= let
- use_mentioned_vars = sw_chkr UseGetMentionedVars
+ use_mentioned_vars = opt_UseGetMentionedVars
in
- BIND (
- BSCC("Rename1")
- initRn12 mod_name (rnModule1 gnfs use_mentioned_vars input)
- ESCC
- ) _TO_ ((mod1, imported_module_names), errs1) ->
+ case (initRn12 mod_name (rnModule1 gnfs use_mentioned_vars input))
+ of { ((mod1, imported_module_names), errs1) ->
- BIND (
- BSCC("Rename2")
- initRn12 mod_name (rnModule2 mod1)
- ESCC
- ) _TO_ (mod2, errs2) ->
+ case (initRn12 mod_name (rnModule2 mod1)) of { (mod2, errs2) ->
--- pprTrace "rename2:" (ppr PprDebug mod2) (
+ case (splitUniqSupply uniqs) of { (us1, us2) ->
- BIND (splitUniqSupply uniqs) _TO_ (us1, us2) ->
-
- BIND (
- BSCC("Rename3")
- initRn3 (rnModule3 gnfs imported_module_names mod2) us1
- ESCC
- ) _TO_ (val_space, tc_space, v_gnf, tc_gnf, errs3) ->
+ case (initRn3 (rnModule3 gnfs imported_module_names mod2) us1)
+ of { (val_space, tc_space, v_gnf, tc_gnf, errs3) ->
let
final_name_funs = (v_gnf, tc_gnf)
if not (isEmptyBag errs_so_far) then -- give up now
( panic "rename", imported_module_names, final_name_funs, errs_so_far )
else
- BIND (
- BSCC("Rename4")
- initRn4 sw_chkr final_name_funs (rnModule4 mod2) us2
- ESCC
- ) _TO_ (mod4, errs4) ->
-
- ( mod4, imported_module_names, final_name_funs, errs4 )
- BEND
- BEND
--- )
- BEND
- BEND
- BEND
+ case (initRn4 final_name_funs (rnModule mod2) us2)
+ of { (mod4, errs4) ->
+
+ ( mod4, imported_module_names, final_name_funs, errs4 ) }
+ }}}}
\end{code}
Why stop if errors in the first three passes: Suppose you're compiling
Another way to handle this would be for the duplicate detector to
clobber duplicates with some ``safe'' value. Then things would be
-fine in \tr{rnModule4}. Maybe some other time...
+fine in \tr{rnModule}. Maybe some other time...
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename1 where
-import AbsSyn(Module)
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..))
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(PreludeNameFun(..), PreludeNameFuns(..))
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import Unique(Unique)
-data Module a b
-data Bag a
-data InPat a
-type ProtoNamePat = InPat ProtoName
-data Labda a
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-type PreludeNameFun = _PackedString -> Labda Name
-type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-rnModule1 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Bool -> Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((Module ProtoName (InPat ProtoName), [_PackedString]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename2 where
-import AbsSyn(Module)
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..))
-import Name(Name)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import SrcLoc(SrcLoc)
-data Module a b
-data Bag a
-data InPat a
-type ProtoNamePat = InPat ProtoName
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-rnModule2 :: Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (Module ProtoName (InPat ProtoName), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename3 where
-import AbsSyn(Module)
-import Bag(Bag)
-import FiniteMap(FiniteMap)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..))
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(ExportFlag)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(PreludeNameFun(..), PreludeNameFuns(..))
-import RenameMonad3(Rn3M(..), initRn3)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import Unique(Unique)
-data Module a b
-data Bag a
-data InPat a
-type ProtoNamePat = InPat ProtoName
-data Labda a
-data Name
-data ExportFlag
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-type PreludeNameFun = _PackedString -> Labda Name
-type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-data SplitUniqSupply
-initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a
-rnModule3 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> [_PackedString] -> Module ProtoName (InPat ProtoName) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> ([(ProtoName, Name)], [(ProtoName, Name)], ProtoName -> Labda Name, ProtoName -> Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Rename4 where
-import AbsSyn(Module)
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, ProtoNamePat(..), RenamedPat(..))
-import HsPragmas(GenPragmas)
-import HsTypes(MonoType, PolyType)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..))
-import RenameMonad4(Rn4M(..), TyVarNamesEnv(..), initRn4)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import Unique(Unique)
-data Module a b
-data Bag a
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data InPat a
-type ProtoNamePat = InPat ProtoName
-type RenamedPat = InPat Name
-data PolyType a
-data Labda a
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-type GlobalNameFun = ProtoName -> Labda Name
-type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-type TyVarNamesEnv = [(ProtoName, Name)]
-data SplitUniqSupply
-data SrcLoc
-initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnGenPragmas4 :: GenPragmas ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GenPragmas Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnModule4 :: Module ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Module Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnPolyType4 :: Bool -> Bool -> [(ProtoName, Name)] -> PolyType ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (PolyType Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameAuxFuns where
-import Bag(Bag)
-import Maybes(Labda)
-import Name(Name)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-data Bag a
-type GlobalNameFun = ProtoName -> Labda Name
-type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
-data Labda a
-type PreludeNameFun = _PackedString -> Labda Name
-type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-data ProtoName
-mkGlobalNameFun :: _PackedString -> (_PackedString -> Labda Name) -> [(ProtoName, Name)] -> ProtoName -> Labda Name
-mkNameFun :: Bag (_PackedString, a) -> (_PackedString -> Labda a, [[(_PackedString, a)]])
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameBinds4 where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsExpr(Expr)
-import HsLit(Literal)
-import HsMatches(GRHSsAndBinds, Match)
-import HsPat(InPat)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..))
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Bag a
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Binds a b
-type DefinedVars = UniqFM Name
-type FreeVars = UniqFM Name
-data MonoBinds a b
-data InPat a
-data Labda a
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-type GlobalNameFun = ProtoName -> Labda Name
-data SplitUniqSupply
-data SrcLoc
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-rnBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Binds Name (InPat Name), UniqFM Name, [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnMethodBinds4 :: Name -> MonoBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (MonoBinds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnTopBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Binds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameExpr4 where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import FiniteMap(FiniteMap)
-import HsBinds(Binds)
-import HsLit(Literal)
-import HsMatches(GRHS, GRHSsAndBinds, Match)
-import HsPat(InPat)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..))
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-data Bag a
-data GRHSsAndBinds a b
-data InPat a
-data Labda a
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-type GlobalNameFun = ProtoName -> Labda Name
-data SplitUniqSupply
-data SrcLoc
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-rnGRHSsAndBinds4 :: GRHSsAndBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((GRHSsAndBinds Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnMatch4 :: Match ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Match Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-rnPat4 :: InPat ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (InPat Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[RenameExpr]{Renaming of expressions}
-
-Basically dependency analysis.
-
-Handles @Match@, @GRHSsAndBinds@, @Expr@, and @Qual@ datatypes. In
-general, all of these functions return a renamed thing, and a set of
-free variables.
-
-\begin{code}
-#include "HsVersions.h"
-
-module RenameExpr4 (
- rnMatch4, rnGRHSsAndBinds4, rnPat4,
-
- -- and to make the interface self-sufficient...
- Bag, GRHSsAndBinds, InPat, Name, Maybe,
- ProtoName, GlobalNameFun(..), UniqSet(..), UniqFM, SrcLoc,
- Unique, SplitUniqSupply,
- Pretty(..), PprStyle, PrettyRep
- ) where
-
-import AbsSyn
-import NameTypes ( FullName )
-import Outputable
-import ProtoName ( ProtoName(..) )
-import Rename4 ( rnPolyType4 )
-import RenameAuxFuns ( GlobalNameFuns(..) ) -- ToDo: rm this line
-import RenameBinds4 ( rnBinds4, FreeVars(..) )
-import RenameMonad4
-import UniqSet
-import Util
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{Patterns}
-* *
-*********************************************************
-
-\begin{code}
-rnPat4 :: ProtoNamePat -> Rn4M RenamedPat
-
-rnPat4 WildPatIn = returnRn4 WildPatIn
-
-rnPat4 (VarPatIn name)
- = lookupValue name `thenRn4` \ vname ->
- returnRn4 (VarPatIn vname)
-
-rnPat4 (LitPatIn n) = returnRn4 (LitPatIn n)
-
-rnPat4 (LazyPatIn pat)
- = rnPat4 pat `thenRn4` \ pat' ->
- returnRn4 (LazyPatIn pat')
-
-rnPat4 (AsPatIn name pat)
- = rnPat4 pat `thenRn4` \ pat' ->
- lookupValue name `thenRn4` \ vname ->
- returnRn4 (AsPatIn vname pat')
-
-rnPat4 (ConPatIn name pats)
- = lookupValue name `thenRn4` \ name' ->
- mapRn4 rnPat4 pats `thenRn4` \ patslist ->
- returnRn4 (ConPatIn name' patslist)
-
-rnPat4 (ConOpPatIn pat1 name pat2)
- = lookupValue name `thenRn4` \ name' ->
- rnPat4 pat1 `thenRn4` \ pat1' ->
- rnPat4 pat2 `thenRn4` \ pat2' ->
- returnRn4 (ConOpPatIn pat1' name' pat2')
-
-rnPat4 (ListPatIn pats)
- = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
- returnRn4 (ListPatIn patslist)
-
-rnPat4 (TuplePatIn pats)
- = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
- returnRn4 (TuplePatIn patslist)
-
-rnPat4 (NPlusKPatIn name lit)
- = lookupValue name `thenRn4` \ vname ->
- returnRn4 (NPlusKPatIn vname lit)
-
-#ifdef DPH
-rnPat4 (ProcessorPatIn pats pat)
- = mapRn4 rnPat4 pats `thenRn4` \ pats' ->
- rnPat4 pat `thenRn4` \ pat' ->
- returnRn4 (ProcessorPatIn pats' pat')
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-************************************************************************
-* *
-\subsection{Match}
-* *
-************************************************************************
-
-\begin{code}
-rnMatch4 :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars)
-
-rnMatch4 match
- = getSrcLocRn4 `thenRn4` \ src_loc ->
- namesFromProtoNames "variable in pattern"
- (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
- extendSS2 new_binders (rnMatch4_aux match)
- where
- binders = collect_binders match
-
- collect_binders :: ProtoNameMatch -> [ProtoName]
-
- collect_binders (GRHSMatch _) = []
- collect_binders (PatMatch pat match)
- = collectPatBinders pat ++ collect_binders match
-
-rnMatch4_aux (PatMatch pat match)
- = rnPat4 pat `thenRn4` \ pat' ->
- rnMatch4_aux match `thenRn4` \ (match', fvMatch) ->
- returnRn4 (PatMatch pat' match', fvMatch)
-
-rnMatch4_aux (GRHSMatch grhss_and_binds)
- = rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
- returnRn4 (GRHSMatch grhss_and_binds', fvs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[dep-GRHSs]{Guarded right-hand sides (GRHSsAndBinds)}
-%* *
-%************************************************************************
-
-\begin{code}
-rnGRHSsAndBinds4 :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars)
-
-rnGRHSsAndBinds4 (GRHSsAndBindsIn grhss binds)
- = rnBinds4 binds `thenRn4` \ (binds', fvBinds, scope) ->
- extendSS2 scope (rnGRHSs4 grhss) `thenRn4` \ (grhss', fvGRHS) ->
- returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
- where
- rnGRHSs4 [] = returnRn4 ([], emptyUniqSet)
-
- rnGRHSs4 (grhs:grhss)
- = rnGRHS4 grhs `thenRn4` \ (grhs', fvs) ->
- rnGRHSs4 grhss `thenRn4` \ (grhss', fvss) ->
- returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss)
-
- rnGRHS4 (GRHS guard expr locn)
- = pushSrcLocRn4 locn (
- rnExpr4 guard `thenRn4` \ (guard', fvsg) ->
- rnExpr4 expr `thenRn4` \ (expr', fvse) ->
- returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
- )
-
- rnGRHS4 (OtherwiseGRHS expr locn)
- = pushSrcLocRn4 locn (
- rnExpr4 expr `thenRn4` \ (expr', fvs) ->
- returnRn4 (OtherwiseGRHS expr' locn, fvs)
- )
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[dep-Expr]{Expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-rnExprs4 :: [ProtoNameExpr] -> Rn4M ([RenamedExpr], FreeVars)
-
-rnExprs4 [] = returnRn4 ([], emptyUniqSet)
-
-rnExprs4 (expr:exprs)
- = rnExpr4 expr `thenRn4` \ (expr', fvExpr) ->
- rnExprs4 exprs `thenRn4` \ (exprs', fvExprs) ->
- returnRn4 (expr':exprs', fvExpr `unionUniqSets` fvExprs)
-\end{code}
-
-Variables. We look up the variable and return the resulting name. The
-interesting question is what the free-variable set should be. We
-don't want to return imported or prelude things as free vars. So we
-look at the Name returned from the lookup, and make it part of the
-free-var set iff:
-\begin{itemize}
-\item
-if it's a @Short@,
-\item
-or it's an @OtherTopId@ and it's defined in this module
-(this includes locally-defined constructrs, but that's too bad)
-\end{itemize}
-
-\begin{code}
-rnExpr4 :: ProtoNameExpr -> Rn4M (RenamedExpr, FreeVars)
-
-rnExpr4 (Var v)
- = lookupValue v `thenRn4` \ vname ->
- returnRn4 (Var vname, fv_set vname)
- where
- fv_set n@(Short uniq sname) = singletonUniqSet n
- fv_set n@(OtherTopId uniq fname)
- | isLocallyDefined fname
- && not (isConop (getOccurrenceName fname))
- = singletonUniqSet n
- fv_set other = emptyUniqSet
-
-rnExpr4 (Lit lit) = returnRn4 (Lit lit, emptyUniqSet)
-
-rnExpr4 (Lam match)
- = rnMatch4 match `thenRn4` \ (match', fvMatch) ->
- returnRn4 (Lam match', fvMatch)
-
-rnExpr4 (App fun arg)
- = rnExpr4 fun `thenRn4` \ (fun',fvFun) ->
- rnExpr4 arg `thenRn4` \ (arg',fvArg) ->
- returnRn4 (App fun' arg', fvFun `unionUniqSets` fvArg)
-
-rnExpr4 (OpApp e1 op e2)
- = rnExpr4 e1 `thenRn4` \ (e1', fvs_e1) ->
- rnExpr4 op `thenRn4` \ (op', fvs_op) ->
- rnExpr4 e2 `thenRn4` \ (e2', fvs_e2) ->
- returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
-
-rnExpr4 (SectionL expr op)
- = rnExpr4 expr `thenRn4` \ (expr', fvs_expr) ->
- rnExpr4 op `thenRn4` \ (op', fvs_op) ->
- returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
-
-rnExpr4 (SectionR op expr)
- = rnExpr4 op `thenRn4` \ (op', fvs_op) ->
- rnExpr4 expr `thenRn4` \ (expr', fvs_expr) ->
- returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
-
-rnExpr4 (CCall fun args may_gc is_casm fake_result_ty)
- = rnExprs4 args `thenRn4` \ (args', fvs_args) ->
- returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
-
-rnExpr4 (SCC label expr)
- = rnExpr4 expr `thenRn4` \ (expr', fvs_expr) ->
- returnRn4 (SCC label expr', fvs_expr)
-
-rnExpr4 (Case expr ms)
- = rnExpr4 expr `thenRn4` \ (new_expr, e_fvs) ->
- mapAndUnzipRn4 rnMatch4 ms `thenRn4` \ (new_ms, ms_fvs) ->
- returnRn4 (Case new_expr new_ms, unionManyUniqSets (e_fvs : ms_fvs))
-
-rnExpr4 (ListComp expr quals)
- = rnQuals4 quals `thenRn4` \ ((quals', qual_binders), fvQuals) ->
- extendSS2 qual_binders (rnExpr4 expr) `thenRn4` \ (expr', fvExpr) ->
- returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
-
-rnExpr4 (Let binds expr)
- = rnBinds4 binds `thenRn4` \ (binds', fvBinds, new_binders) ->
- extendSS2 new_binders (rnExpr4 expr) `thenRn4` \ (expr',fvExpr) ->
- returnRn4 (Let binds' expr', fvBinds `unionUniqSets` fvExpr)
-
-rnExpr4 (ExplicitList exps)
- = rnExprs4 exps `thenRn4` \ (exps', fvs) ->
- returnRn4 (ExplicitList exps', fvs)
-
-rnExpr4 (ExplicitTuple exps)
- = rnExprs4 exps `thenRn4` \ (exps', fvExps) ->
- returnRn4 (ExplicitTuple exps', fvExps)
-
-rnExpr4 (ExprWithTySig expr pty)
- = rnExpr4 expr `thenRn4` \ (expr', fvExpr) ->
- rnPolyType4 False True nullTyVarNamesEnv pty `thenRn4` \ pty' ->
- returnRn4 (ExprWithTySig expr' pty', fvExpr)
-
-rnExpr4 (If p b1 b2)
- = rnExpr4 p `thenRn4` \ (p', fvP) ->
- rnExpr4 b1 `thenRn4` \ (b1', fvB1) ->
- rnExpr4 b2 `thenRn4` \ (b2', fvB2) ->
- returnRn4 (If p' b1' b2', unionManyUniqSets [fvP, fvB1, fvB2])
-
-rnExpr4 (ArithSeqIn seq)
- = rn_seq seq `thenRn4` \ (new_seq, fvs) ->
- returnRn4 (ArithSeqIn new_seq, fvs)
- where
- rn_seq (From expr)
- = rnExpr4 expr `thenRn4` \ (expr', fvExpr) ->
- returnRn4 (From expr', fvExpr)
-
- rn_seq (FromThen expr1 expr2)
- = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) ->
- rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) ->
- returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
-
- rn_seq (FromTo expr1 expr2)
- = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) ->
- rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) ->
- returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
-
- rn_seq (FromThenTo expr1 expr2 expr3)
- = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) ->
- rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) ->
- rnExpr4 expr3 `thenRn4` \ (expr3', fvExpr3) ->
- returnRn4 (FromThenTo expr1' expr2' expr3',
- unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
-
-#ifdef DPH
-rnExpr4 (ParallelZF expr quals)
- = rnParQuals4 quals `thenRn4` \ ((quals',binds),fvQuals)->
- extendSS2 binds
- (rnExpr4 expr) `thenRn4` \ (expr', fvExpr ) ->
- returnRn4 (ParallelZF expr' quals' , fvExpr `unionUniqSets` fvQuals)
-
-rnExpr4 (ExplicitProcessor exprs expr)
- = rnExprs4 exprs `thenRn4` \ (exprs',fvExprs) ->
- rnExpr4 expr `thenRn4` \ (expr' ,fvExpr) ->
- returnRn4 (ExplicitProcessor exprs' expr',fvExprs `unionUniqSets` fvExpr)
-
-rnExpr4 (ExplicitPodIn exprs)
- = rnExprs4 exprs `thenRn4` \ (exprs',fvExprs) ->
- returnRn4 (ExplicitPodIn exprs',fvExprs)
-
--- ExplicitPodOut : not in ProtoNameExprs (pops out of typechecker :-)
-
-#endif {- Data Parallel Haskell -}
-
--- ArithSeqOut: not in ProtoNameExprs
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[dep-Quals]{@Qual@s: in list comprehensions}
-%* *
-%************************************************************************
-
-Note that although some bound vars may appear in the free var set for
-the first qual, these will eventually be removed by the caller. For
-example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
-@(AndQuals (q <- r) (p <- q))@, the free var set for @(q <- r)@ will
-be @[r]@, and the free var set for the entire Quals will be @[r]@. This
-@r@ will be removed only when we finally return from examining all the
-Quals.
-
-\begin{code}
-rnQuals4 :: [ProtoNameQual] -> Rn4M (([RenamedQual], [Name]), FreeVars)
-
-rnQuals4 [qual]
- = rnQual4 qual `thenRn4` \ ((new_qual, bs), fvs) ->
- returnRn4 (([new_qual], bs), fvs)
-
-rnQuals4 (qual: quals)
- = rnQual4 qual `thenRn4` \ ((qual', bs1), fvQuals1) ->
- extendSS2 bs1 (rnQuals4 quals) `thenRn4` \ ((quals', bs2), fvQuals2) ->
- returnRn4
- ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the
- -- ones on the left (bs1)
- fvQuals1 `unionUniqSets` fvQuals2)
-
-rnQual4 (GeneratorQual pat expr)
- = rnExpr4 expr `thenRn4` \ (expr', fvExpr) ->
- let
- binders = collectPatBinders pat
- in
- getSrcLocRn4 `thenRn4` \ src_loc ->
- namesFromProtoNames "variable in list-comprehension-generator pattern"
- (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
- extendSS new_binders (rnPat4 pat) `thenRn4` \ pat' ->
-
- returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr)
-
-rnQual4 (FilterQual expr)
- = rnExpr4 expr `thenRn4` \ (expr', fvs) ->
- returnRn4 ((FilterQual expr', []), fvs)
-\end{code}
-
-%************************************************************************
-%* *
-%* Parallel Quals (in Parallel Zf expressions) *
-%* *
-%************************************************************************
-\subsubsection[dep-ParQuals]{ParQuals}
-
-\begin{code}
-#ifdef DPH
-rnPats4 :: [ProtoNamePat] -> Rn4M [RenamedPat]
-rnPats4 [] = returnRn4 []
-rnPats4 (pat:pats)
- = (rnPat4 pat) `thenRn4` (\ pat' ->
- (rnPats4 pats) `thenRn4` (\ pats' ->
- returnRn4 (pat':pats') ))
-
-rnParQuals4 :: ProtoNameParQuals -> Rn4M ((RenamedParQuals, [Name]), FreeVars)
-
-rnParQuals4 (AndParQuals q1 q2)
- = rnParQuals4 q1 `thenRn4` (\ ((quals1', bs1), fvQuals1) ->
- extendSS2 bs1 (rnParQuals4 q2)
- `thenRn4` (\ ((quals2', bs2), fvQuals2) ->
- returnRn4 ((AndParQuals quals1' quals2', bs2 ++ bs1),
- fvQuals1 `unionUniqSets` fvQuals2) ))
-
-
-rnParQuals4 (DrawnGenIn pats pat expr)
- = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) ->
- let_1_0 (concat (map collectPatBinders pats)) (\ binders1 ->
- getSrcLocRn4 `thenRn4` (\ src_loc ->
- namesFromProtoNames "variable in pattern"
- (binders1 `zip` repeat src_loc)
- `thenRn4` (\ binders1' ->
- extendSS binders1' (rnPats4 pats)
- `thenRn4` (\ pats' ->
- let_1_0 (collectPatBinders pat) (\ binders2 ->
- namesFromProtoNames "variable in pattern"
- (binders2 `zip` repeat src_loc)
- `thenRn4` (\ binders2' ->
- extendSS binders2' (rnPat4 pat)
- `thenRn4` (\ pat' ->
- returnRn4 ((DrawnGenIn pats' pat' expr' , binders1' ++ binders2'),
- fvExpr) ))))))))
-
-rnParQuals4 (IndexGen exprs pat expr)
- = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) ->
- rnExprs4 exprs `thenRn4` (\ (exprs', fvExprs) ->
- let_1_0 (collectPatBinders pat) (\ binders ->
- getSrcLocRn4 `thenRn4` (\ src_loc ->
- namesFromProtoNames "variable in pattern"
- (binders `zip` repeat src_loc)
- `thenRn4` (\ binders' ->
- extendSS binders' (rnPat4 pat)
- `thenRn4` (\ pat' ->
- returnRn4 ((IndexGen exprs' pat' expr' , binders'),
- fvExpr `unionUniqSets` fvExprs) ))))))
-
-rnParQuals4 (ParFilter expr)
- = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) ->
- returnRn4 ((ParFilter expr', []), fvExpr) )
-#endif {- Data Parallel Haskell -}
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameMonad12 where
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-infixr 9 `thenRn12`
-data Bag a
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-type Rn12M a = _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-addErrRn12 :: (PprStyle -> Int -> Bool -> PrettyRep) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-foldrRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> b -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getModuleNameRn12 :: _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (_PackedString, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-initRn12 :: _PackedString -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mapRn12 :: (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep))
-recoverQuietlyRn12 :: a -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-returnRn12 :: a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-thenRn12 :: (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-zipWithRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (c, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> [b] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([c], Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameMonad3 where
-import FiniteMap(FiniteMap)
-import HsImpExp(IE)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName)
-import Outputable(ExportFlag)
-import PreludePS(_PackedString)
-import ProtoName(ProtoName)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Unique(Unique)
-infixr 9 `thenRn3`
-data IE
-data FullName
-data ExportFlag
-data ProtoName
-type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-data SplitUniqSupply
-data Unique
-andRn3 :: (a -> a -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-fixRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a
-mapRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> [a] -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> [b]
-newFullNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName)
-newInvisibleNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName)
-putInfoDownM3 :: _PackedString -> [IE] -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-returnRn3 :: a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-thenRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface RenameMonad4 where
-import AbsSyn(Module)
-import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsPat(InPat, RenamedPat(..))
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..))
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-infixr 9 `thenRn4`
-infixr 9 `thenRn4_`
-data Module a b
-data Bag a
-data GlobalSwitch
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data InPat a
-type RenamedPat = InPat Name
-data Labda a
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-type GlobalNameFun = ProtoName -> Labda Name
-type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
-type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-data SplitUniqSupply
-data SrcLoc
-type TyVarNamesEnv = [(ProtoName, Name)]
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-addErrRn4 :: (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-andRn4 :: (a -> a -> a) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-catTyVarNamesEnvs :: [(ProtoName, Name)] -> [(ProtoName, Name)] -> [(ProtoName, Name)]
-domTyVarNamesEnv :: [(ProtoName, Name)] -> [ProtoName]
-extendSS :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-extendSS2 :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-failButContinueRn4 :: a -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getSrcLocRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (SrcLoc, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getSwitchCheckerRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> Bool, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupClass :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupClassOp :: Name -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupFixityOp :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupTyCon :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupTyConEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupTyVarName :: [(ProtoName, Name)] -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupValue :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-lookupValueEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mapAndUnzipRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((b, c), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([b], [c]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mapRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mkTyVarNamesEnv :: SrcLoc -> [ProtoName] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([(ProtoName, Name)], [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
-namesFromProtoNames :: [Char] -> [(ProtoName, SrcLoc)] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([Name], Bag (PprStyle -> Int -> Bool -> PrettyRep))
-nullTyVarNamesEnv :: [(ProtoName, Name)]
-pushSrcLocRn4 :: SrcLoc -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-recoverQuietlyRn4 :: a -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-returnRn4 :: a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-thenRn4 :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-thenRn4_ :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[RenameBinds4]{Renaming and dependency analysis of bindings}
+\section[RnBinds4]{Renaming and dependency analysis of bindings}
This module does renaming and dependency analysis on value bindings in
-@AbsSyntax@ programs. It does {\em not} do cycle-checks on class or
+the abstract syntax. It does {\em not} do cycle-checks on class or
type-synonym declarations; those cannot be done at this stage because
they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
#include "HsVersions.h"
-module RenameBinds4 (
- rnTopBinds4, rnMethodBinds4,
- rnBinds4,
- FreeVars(..), DefinedVars(..),
+module RnBinds4 (
+ rnTopBinds, rnMethodBinds,
+ rnBinds,
+ FreeVars(..), DefinedVars(..)
-- and to make the interface self-sufficient...
- Bag, Binds, MonoBinds, InPat, Name, ProtoName,
- GlobalNameFun(..), Maybe, UniqSet(..), UniqFM, SrcLoc, Unique,
- SplitUniqSupply, Error(..), Pretty(..), PprStyle,
- PrettyRep
) where
-import AbsSyn
-import CmdLineOpts ( GlobalSwitch(..) )
-import Digraph ( stronglyConnComp {- MOVED HERE: , isCyclic -} )
-import Errors -- ( unknownSigDeclErr, dupSigDeclErr, methodBindErr )
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import Maybes ( catMaybes, Maybe(..) )
-import Name ( eqName, cmpName, isUnboundName )
-import ProtoName ( elemByLocalNames, eqByLocalName )
-import Rename4 ( rnPolyType4, rnGenPragmas4 )
-import RenameAuxFuns ( GlobalNameFuns(..) )
-import RenameMonad4
-import RenameExpr4 ( rnMatch4, rnGRHSsAndBinds4, rnPat4 )
-import UniqSet
-import Util
+import Ubiq{-uitous-}
+import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+import HsPragmas ( noGenPragmas )
+import RnMonad4
+
+-- others:
+import CmdLineOpts ( opt_SigsRequired )
+import Digraph ( stronglyConnComp )
+import ErrUtils ( addErrLoc, addShortErrLocLine )
+import Maybes ( catMaybes )
+import Name ( isUnboundName, Name{-instances-} )
+import Pretty
+import ProtoName ( elemByLocalNames, eqByLocalName, ProtoName{-instances-} )
+import RnExpr4 -- OK to look here; but not the other way 'round
+import UniqSet ( emptyUniqSet, singletonUniqSet, mkUniqSet,
+ unionUniqSets, unionManyUniqSets,
+ elementOfUniqSet,
+ uniqSetToList,
+ UniqSet(..)
+ )
+import Util ( isIn, removeDups, panic, panic# )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
-- place and can be used when complaining.
-The code tree received by the function @rnBinds4@ contains definitions
+The code tree received by the function @rnBinds@ contains definitions
in where-clauses which are all apparently mutually recursive, but which may
not really depend upon each other. For example, in the top level program
\begin{verbatim}
Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
However, the typechecker usually can check definitions in which only the
strongly connected components have been collected into recursive bindings.
-This is precisely what the function @rnBinds4@ does.
+This is precisely what the function @rnBinds@ does.
ToDo: deal with case where a single monobinds binds the same variable
twice.
The basic algorithm involves walking over the tree and returning a tuple
containing the new tree plus its free variables. Some functions, such
-as those walking polymorphic bindings (Binds) and qualifier lists in
+as those walking polymorphic bindings (HsBinds) and qualifier lists in
list comprehensions (@Quals@), return the variables bound in local
environments. These are then used to calculate the free variables of the
expression evaluated in these environments.
%************************************************************************
%* *
-%* analysing polymorphic bindings (Binds, Bind, MonoBinds) *
+%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
%* *
%************************************************************************
-\subsubsection[dep-Binds]{Polymorphic bindings}
+\subsubsection[dep-HsBinds]{Polymorphic bindings}
Non-recursive expressions are reconstructed without any changes at top
level, although their component expressions may have to be altered.
union of those in the previous set plus those of the newest binding after
the defined variables of the previous set have been removed.
-@rnMethodBinds4@ deals only with the declarations in class and
+@rnMethodBinds@ deals only with the declarations in class and
instance declarations. It expects only to see @FunMonoBind@s, and
it expects the global environment to contain bindings for the binders
(which are all class operations).
\begin{code}
-rnTopBinds4 :: ProtoNameBinds -> Rn4M RenamedBinds
-rnMethodBinds4 :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds
-rnBinds4 :: ProtoNameBinds -> Rn4M (RenamedBinds, FreeVars, [Name])
+rnTopBinds :: ProtoNameHsBinds -> Rn4M RenamedHsBinds
+rnMethodBinds :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds
+rnBinds :: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name])
-rnTopBinds4 EmptyBinds = returnRn4 EmptyBinds
-rnTopBinds4 (SingleBind (RecBind bind)) = rnTopMonoBinds4 bind []
-rnTopBinds4 (BindWith (RecBind bind) sigs) = rnTopMonoBinds4 bind sigs
+rnTopBinds EmptyBinds = returnRn4 EmptyBinds
+rnTopBinds (SingleBind (RecBind bind)) = rnTopMonoBinds bind []
+rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
-- the parser doesn't produce other forms
-- ********************************************************************
-rnMethodBinds4 class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds
+rnMethodBinds class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds
-rnMethodBinds4 class_name (AndMonoBinds mb1 mb2)
- = andRn4 AndMonoBinds (rnMethodBinds4 class_name mb1)
- (rnMethodBinds4 class_name mb2)
+rnMethodBinds class_name (AndMonoBinds mb1 mb2)
+ = andRn4 AndMonoBinds (rnMethodBinds class_name mb1)
+ (rnMethodBinds class_name mb2)
-rnMethodBinds4 class_name (FunMonoBind pname matches locn)
+rnMethodBinds class_name (FunMonoBind pname matches locn)
= pushSrcLocRn4 locn (
lookupClassOp class_name pname `thenRn4` \ op_name ->
- mapAndUnzipRn4 rnMatch4 matches `thenRn4` \ (new_matches, _) ->
+ mapAndUnzipRn4 rnMatch matches `thenRn4` \ (new_matches, _) ->
returnRn4 (FunMonoBind op_name new_matches locn)
)
-rnMethodBinds4 class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn)
+rnMethodBinds class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn)
= pushSrcLocRn4 locn (
lookupClassOp class_name pname `thenRn4` \ op_name ->
- rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', _) ->
+ rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', _) ->
returnRn4 (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
)
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBinds4 _ mbind@(PatMonoBind other_pat _ locn)
+rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
= failButContinueRn4 EmptyMonoBinds (methodBindErr mbind locn)
-- ********************************************************************
-rnBinds4 EmptyBinds = returnRn4 (EmptyBinds,emptyUniqSet,[])
-rnBinds4 (SingleBind (RecBind bind)) = rnNestedMonoBinds4 bind []
-rnBinds4 (BindWith (RecBind bind) sigs) = rnNestedMonoBinds4 bind sigs
+rnBinds EmptyBinds = returnRn4 (EmptyBinds,emptyUniqSet,[])
+rnBinds (SingleBind (RecBind bind)) = rnNestedMonoBinds bind []
+rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs
-- the parser doesn't produce other forms
\end{code}
-@rnNestedMonoBinds4@
+@rnNestedMonoBinds@
- collects up the binders for this declaration group,
- checkes that they form a set
- extends the environment to bind them to new local names
- - calls @rnMonoBinds4@ to do the real work
+ - calls @rnMonoBinds@ to do the real work
-In contrast, @rnTopMonoBinds4@ doesn't extend the environment, because that's
-already done in pass3. All it does is call @rnMonoBinds4@ and discards
+In contrast, @rnTopMonoBinds@ doesn't extend the environment, because that's
+already done in pass3. All it does is call @rnMonoBinds@ and discards
the free var info.
\begin{code}
-rnTopMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedBinds
+rnTopMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedHsBinds
-rnTopMonoBinds4 EmptyMonoBinds sigs = returnRn4 EmptyBinds
+rnTopMonoBinds EmptyMonoBinds sigs = returnRn4 EmptyBinds
-rnTopMonoBinds4 mbs sigs
- = rnBindSigs4 True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist ->
- rnMonoBinds4 mbs siglist `thenRn4` \ (new_binds, fv_set) ->
+rnTopMonoBinds mbs sigs
+ = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist ->
+ rnMonoBinds mbs siglist `thenRn4` \ (new_binds, fv_set) ->
returnRn4 new_binds
-rnNestedMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig]
- -> Rn4M (RenamedBinds, FreeVars, [Name])
+rnNestedMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig]
+ -> Rn4M (RenamedHsBinds, FreeVars, [Name])
-rnNestedMonoBinds4 EmptyMonoBinds sigs
+rnNestedMonoBinds EmptyMonoBinds sigs
= returnRn4 (EmptyBinds, emptyUniqSet, [])
-rnNestedMonoBinds4 mbinds sigs -- Non-empty monobinds
+rnNestedMonoBinds mbinds sigs -- Non-empty monobinds
=
-- Extract all the binders in this group,
-- and extend current scope, inventing new names for the new binders
mbinders_w_srclocs `thenRn4` \ new_mbinders ->
extendSS2 new_mbinders (
- rnBindSigs4 False{-not top- level-} mbinders sigs `thenRn4` \ siglist ->
- rnMonoBinds4 mbinds siglist
+ rnBindSigs False{-not top- level-} mbinders sigs `thenRn4` \ siglist ->
+ rnMonoBinds mbinds siglist
) `thenRn4` \ (new_binds, fv_set) ->
returnRn4 (new_binds, fv_set, new_mbinders)
\end{code}
-@rnMonoBinds4@ is used by *both* top-level and nested bindings. It
+@rnMonoBinds@ is used by *both* top-level and nested bindings. It
assumes that all variables bound in this group are already in scope.
This is done *either* by pass 3 (for the top-level bindings),
-*or* by @rnNestedMonoBinds4@ (for the nested ones).
+*or* by @rnNestedMonoBinds@ (for the nested ones).
\begin{code}
-rnMonoBinds4 :: ProtoNameMonoBinds
+rnMonoBinds :: ProtoNameMonoBinds
-> [RenamedSig] -- Signatures attached to this group
- -> Rn4M (RenamedBinds, FreeVars)
+ -> Rn4M (RenamedHsBinds, FreeVars)
-rnMonoBinds4 mbinds siglist
+rnMonoBinds mbinds siglist
=
-- Rename the bindings, returning a MonoBindsInfo
-- which is a list of indivisible vertices so far as
- -- the SCC analysis is concerned
+ -- the strongly-connected-components (SCC) analysis is concerned
flattenMonoBinds 0 siglist mbinds `thenRn4` \ (_, mbinds_info) ->
-- Do the SCC analysis
rhs_free_vars = foldr f emptyUniqSet mbinds_info
final_binds = reconstructRec scc_result edges mbinds_info
-
+
happy_answer = returnRn4 (final_binds, rhs_free_vars)
in
case (inline_sigs_in_recursive_binds final_binds) of
f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
- = case [(n, locn) | (InlineSig n _ locn) <- sigs ] of
+ = case [(n, locn) | (InlineSig n locn) <- sigs ] of
[] -> Nothing
- sigh ->
+ sigh ->
#if OMIT_DEFORESTER
Just sigh
#else
flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
= pushSrcLocRn4 locn (
- rnPat4 pat `thenRn4` \ pat' ->
- rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
+ rnPat pat `thenRn4` \ pat' ->
+ rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
-- Find which things are bound in this group
let
flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
= pushSrcLocRn4 locn (
lookupValue name `thenRn4` \ name' ->
- mapAndUnzipRn4 rnMatch4 matches `thenRn4` \ (new_matches, fv_lists) ->
+ mapAndUnzipRn4 rnMatch matches `thenRn4` \ (new_matches, fv_lists) ->
let
fvs = unionManyUniqSets fv_lists
- sigs_for_me = foldl (sig_for_here (\ n -> n `eqName` name')) [] sigs
+ sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs
sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
in
returnRn4 (
uniq + 1,
[(uniq,
- singletonUniqSet name',
+ singletonUniqSet name',
fvs `unionUniqSets` sigs_fvs,
FunMonoBind name' new_matches locn,
sigs_for_me
Grab type-signatures/user-pragmas of interest:
\begin{code}
sig_for_here want_me acc s@(Sig n _ _ _) | want_me n = s:acc
-sig_for_here want_me acc s@(InlineSig n _ _) | want_me n = s:acc
+sig_for_here want_me acc s@(InlineSig n _) | want_me n = s:acc
sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc
sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc
sig_for_here want_me acc s@(MagicUnfoldingSig n _ _)
- | want_me n = s:acc
+ | want_me n = s:acc
sig_for_here want_me acc other_wise = acc
-- If a SPECIALIZE pragma is of the "... = blah" form,
as the two cases are similar.
\begin{code}
-reconstructRec :: [Cycle] -- Result of SCC analysis; at least one
- -> [Edge] -- Original edges
+reconstructRec :: [Cycle] -- Result of SCC analysis; at least one
+ -> [Edge] -- Original edges
-> FlatMonoBindsInfo
- -> RenamedBinds
+ -> RenamedHsBinds
reconstructRec cycles edges mbi
= foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
where
- reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedBinds
+ reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
reconstructCycle mbi2 cycle
= BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
is_elem = isIn "reconstructRec"
mk_binds :: RenamedMonoBinds -> [RenamedSig]
- -> Bool -> Bool -> RenamedBinds
+ -> Bool -> Bool -> RenamedHsBinds
mk_binds bs ss True False = SingleBind (RecBind bs)
mk_binds bs ss True True{-have sigs-} = BindWith (RecBind bs) ss
%* *
%************************************************************************
-@rnBindSigs4@ checks for: (a)~more than one sig for one thing;
+@rnBindSigs@ checks for: (a)~more than one sig for one thing;
(b)~signatures given for things not bound here; (c)~with suitably
flaggery, that all top-level things have type signatures.
\begin{code}
-rnBindSigs4 :: Bool -- True <=> top-level binders
+rnBindSigs :: Bool -- True <=> top-level binders
-> [ProtoName] -- Binders for this decl group
- -> [ProtoNameSig]
+ -> [ProtoNameSig]
-> Rn4M [RenamedSig] -- List of Sig constructors
-rnBindSigs4 is_toplev binder_pnames sigs
+rnBindSigs is_toplev binder_pnames sigs
=
-- Rename the signatures
-- Will complain about sigs for variables not in this group
-- Discard unbound ones we've already complained about, so we
-- complain about duplicate ones.
- (goodies, dups) = removeDups cmp (filter not_unbound sigs')
+ (goodies, dups) = removeDups compare (filter not_unbound sigs')
in
mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_`
- getSwitchCheckerRn4 `thenRn4` \ sw_chkr ->
getSrcLocRn4 `thenRn4` \ locn ->
- (if (is_toplev && sw_chkr SigsRequired) then
+ (if (is_toplev && opt_SigsRequired) then
let
sig_frees = catMaybes (map (sig_free sigs) binder_pnames)
in
returnRn4 Nothing
else
lookupValue v `thenRn4` \ new_v ->
- rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
- recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 pragma
+ rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
+ recoverQuietlyRn4 noGenPragmas (
+ rnGenPragmas pragma
) `thenRn4` \ new_pragma ->
returnRn4 (Just (Sig new_v new_ty new_pragma src_loc))
)
returnRn4 Nothing
else
lookupValue v `thenRn4` \ new_v ->
- rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
+ rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
rn_using using `thenRn4` \ new_using ->
returnRn4 (Just (SpecSig new_v new_ty new_using src_loc))
)
rn_using (Just x) = lookupValue x `thenRn4` \ new_x ->
returnRn4 (Just new_x)
- rename_sig (InlineSig v howto src_loc)
+ rename_sig (InlineSig v src_loc)
= pushSrcLocRn4 src_loc (
if not (v `elemByLocalNames` binder_pnames) then
returnRn4 Nothing
else
lookupValue v `thenRn4` \ new_v ->
- returnRn4 (Just (InlineSig new_v howto src_loc))
+ returnRn4 (Just (InlineSig new_v src_loc))
)
rename_sig (DeforestSig v src_loc)
not_unbound (Sig n _ _ _) = not (isUnboundName n)
not_unbound (SpecSig n _ _ _) = not (isUnboundName n)
- not_unbound (InlineSig n _ _) = not (isUnboundName n)
+ not_unbound (InlineSig n _) = not (isUnboundName n)
not_unbound (DeforestSig n _) = not (isUnboundName n)
not_unbound (MagicUnfoldingSig n _ _) = not (isUnboundName n)
sig_free (_ : rest) ny = sig_free rest ny
-------------------------------------
- cmp :: RenamedSig -> RenamedSig -> TAG_
+ compare :: RenamedSig -> RenamedSig -> TAG_
+ compare x y = c x y
- cmp (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmpName` n2
- cmp (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `cmpName` n2
- cmp (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmpName` n2
- cmp (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
+ c (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmp` n2
+ c (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2
+ c (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
+ c (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
= -- may have many specialisations for one value;
-- but not ones that are exactly the same...
- case (n1 `cmpName` n2) of
- EQ_ -> cmpPolyType cmpName ty1 ty2
+ case (n1 `cmp` n2) of
+ EQ_ -> cmpPolyType cmp ty1 ty2
other -> other
- cmp other_1 other_2 -- tags *must* be different
+ c other_1 other_2 -- tags *must* be different
= let tag1 = tag other_1
tag2 = tag other_2
in
tag (Sig n1 _ _ _) = (ILIT(1) :: FAST_INT)
tag (SpecSig n1 _ _ _) = ILIT(2)
- tag (InlineSig n1 _ _) = ILIT(3)
+ tag (InlineSig n1 _) = ILIT(3)
tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
tag (DeforestSig n1 _) = ILIT(5)
- tag _ = case (panic "tag(RenameBinds4)") of { s -> tag s } -- BUG avoidance
+ tag _ = panic# "tag(RnBinds4)"
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
+
+\begin{code}
+dupSigDeclErr sigs
+ = let
+ undup_sigs = fst (removeDups cmp_sig sigs)
+ in
+ addErrLoc locn1
+ ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty ->
+ ppAboves (map (ppr sty) undup_sigs) )
+ where
+ (what_it_is, locn1)
+ = case (head sigs) of
+ Sig _ _ _ loc -> ("type signature",loc)
+ ClassOpSig _ _ _ loc -> ("class-method type signature", loc)
+ SpecSig _ _ _ loc -> ("SPECIALIZE pragma",loc)
+ InlineSig _ loc -> ("INLINE pragma",loc)
+ MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc)
+
+ cmp_sig a b = get_name a `cmp` get_name b
+
+ get_name (Sig n _ _ _) = n
+ get_name (ClassOpSig n _ _ _) = n
+ get_name (SpecSig n _ _ _) = n
+ get_name (InlineSig n _) = n
+ get_name (MagicUnfoldingSig n _ _) = n
+
+------------------------
+methodBindErr mbind locn
+ = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
+ (\ sty -> ppr sty mbind)
+
+--------------------------
+missingSigErr locn var
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "a definition but no type signature for `",
+ ppr sty var,
+ ppStr "'."])
+
+--------------------------------
+unknownSigDeclErr flavor var locn
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr flavor, ppStr " but no definition for `",
+ ppr sty var,
+ ppStr "'."])
\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnExpr4]{Renaming of expressions (pass 4)}
+
+Basically dependency analysis.
+
+Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes. In
+general, all of these functions return a renamed thing, and a set of
+free variables.
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnExpr4 (
+ rnMatch, rnGRHSsAndBinds, rnPat
+
+ -- and to make the interface self-sufficient...
+ ) where
+
+import Ubiq{-uitous-}
+import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+import RnMonad4
+
+-- others:
+import Name ( Name(..) )
+import NameTypes ( FullName{-instances-} )
+import Outputable ( isConop )
+import UniqSet ( emptyUniqSet, singletonUniqSet,
+ unionUniqSets, unionManyUniqSets,
+ UniqSet(..)
+ )
+import Util ( panic )
+\end{code}
+
+
+*********************************************************
+* *
+\subsection{Patterns}
+* *
+*********************************************************
+
+\begin{code}
+rnPat :: ProtoNamePat -> Rn4M RenamedPat
+
+rnPat WildPatIn = returnRn4 WildPatIn
+
+rnPat (VarPatIn name)
+ = lookupValue name `thenRn4` \ vname ->
+ returnRn4 (VarPatIn vname)
+
+rnPat (LitPatIn n) = returnRn4 (LitPatIn n)
+
+rnPat (LazyPatIn pat)
+ = rnPat pat `thenRn4` \ pat' ->
+ returnRn4 (LazyPatIn pat')
+
+rnPat (AsPatIn name pat)
+ = rnPat pat `thenRn4` \ pat' ->
+ lookupValue name `thenRn4` \ vname ->
+ returnRn4 (AsPatIn vname pat')
+
+rnPat (ConPatIn name pats)
+ = lookupValue name `thenRn4` \ name' ->
+ mapRn4 rnPat pats `thenRn4` \ patslist ->
+ returnRn4 (ConPatIn name' patslist)
+
+rnPat (ConOpPatIn pat1 name pat2)
+ = lookupValue name `thenRn4` \ name' ->
+ rnPat pat1 `thenRn4` \ pat1' ->
+ rnPat pat2 `thenRn4` \ pat2' ->
+ returnRn4 (ConOpPatIn pat1' name' pat2')
+
+rnPat (ListPatIn pats)
+ = mapRn4 rnPat pats `thenRn4` \ patslist ->
+ returnRn4 (ListPatIn patslist)
+
+rnPat (TuplePatIn pats)
+ = mapRn4 rnPat pats `thenRn4` \ patslist ->
+ returnRn4 (TuplePatIn patslist)
+
+rnPat (RecPatIn con rpats)
+ = panic "rnPat:RecPatIn"
+
+\end{code}
+
+************************************************************************
+* *
+\subsection{Match}
+* *
+************************************************************************
+
+\begin{code}
+rnMatch :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars)
+
+rnMatch match
+ = getSrcLocRn4 `thenRn4` \ src_loc ->
+ namesFromProtoNames "variable in pattern"
+ (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
+ extendSS2 new_binders (rnMatch_aux match)
+ where
+ binders = collect_binders match
+
+ collect_binders :: ProtoNameMatch -> [ProtoName]
+
+ collect_binders (GRHSMatch _) = []
+ collect_binders (PatMatch pat match)
+ = collectPatBinders pat ++ collect_binders match
+
+rnMatch_aux (PatMatch pat match)
+ = rnPat pat `thenRn4` \ pat' ->
+ rnMatch_aux match `thenRn4` \ (match', fvMatch) ->
+ returnRn4 (PatMatch pat' match', fvMatch)
+
+rnMatch_aux (GRHSMatch grhss_and_binds)
+ = rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
+ returnRn4 (GRHSMatch grhss_and_binds', fvs)
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
+%* *
+%************************************************************************
+
+\begin{code}
+rnGRHSsAndBinds :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars)
+
+rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
+ = rnBinds binds `thenRn4` \ (binds', fvBinds, scope) ->
+ extendSS2 scope (rnGRHSs grhss) `thenRn4` \ (grhss', fvGRHS) ->
+ returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
+ where
+ rnGRHSs [] = returnRn4 ([], emptyUniqSet)
+
+ rnGRHSs (grhs:grhss)
+ = rnGRHS grhs `thenRn4` \ (grhs', fvs) ->
+ rnGRHSs grhss `thenRn4` \ (grhss', fvss) ->
+ returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss)
+
+ rnGRHS (GRHS guard expr locn)
+ = pushSrcLocRn4 locn (
+ rnExpr guard `thenRn4` \ (guard', fvsg) ->
+ rnExpr expr `thenRn4` \ (expr', fvse) ->
+ returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
+ )
+
+ rnGRHS (OtherwiseGRHS expr locn)
+ = pushSrcLocRn4 locn (
+ rnExpr expr `thenRn4` \ (expr', fvs) ->
+ returnRn4 (OtherwiseGRHS expr' locn, fvs)
+ )
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Expressions}
+%* *
+%************************************************************************
+
+\begin{code}
+rnExprs :: [ProtoNameHsExpr] -> Rn4M ([RenamedHsExpr], FreeVars)
+
+rnExprs [] = returnRn4 ([], emptyUniqSet)
+
+rnExprs (expr:exprs)
+ = rnExpr expr `thenRn4` \ (expr', fvExpr) ->
+ rnExprs exprs `thenRn4` \ (exprs', fvExprs) ->
+ returnRn4 (expr':exprs', fvExpr `unionUniqSets` fvExprs)
+\end{code}
+
+Variables. We look up the variable and return the resulting name. The
+interesting question is what the free-variable set should be. We
+don't want to return imported or prelude things as free vars. So we
+look at the Name returned from the lookup, and make it part of the
+free-var set iff:
+\begin{itemize}
+\item
+if it's a @Short@,
+\item
+or it's an @ValName@ and it's defined in this module
+(this includes locally-defined constructrs, but that's too bad)
+\end{itemize}
+
+\begin{code}
+rnExpr :: ProtoNameHsExpr -> Rn4M (RenamedHsExpr, FreeVars)
+
+rnExpr (HsVar v)
+ = lookupValue v `thenRn4` \ vname ->
+ returnRn4 (HsVar vname, fv_set vname)
+ where
+ fv_set n@(Short uniq sname) = singletonUniqSet n
+ fv_set n@(ValName uniq fname)
+ | isLocallyDefined fname
+ && not (isConop (getOccurrenceName fname))
+ = singletonUniqSet n
+ fv_set other = emptyUniqSet
+
+rnExpr (HsLit lit) = returnRn4 (HsLit lit, emptyUniqSet)
+
+rnExpr (HsLam match)
+ = rnMatch match `thenRn4` \ (match', fvMatch) ->
+ returnRn4 (HsLam match', fvMatch)
+
+rnExpr (HsApp fun arg)
+ = rnExpr fun `thenRn4` \ (fun',fvFun) ->
+ rnExpr arg `thenRn4` \ (arg',fvArg) ->
+ returnRn4 (HsApp fun' arg', fvFun `unionUniqSets` fvArg)
+
+rnExpr (OpApp e1 op e2)
+ = rnExpr e1 `thenRn4` \ (e1', fvs_e1) ->
+ rnExpr op `thenRn4` \ (op', fvs_op) ->
+ rnExpr e2 `thenRn4` \ (e2', fvs_e2) ->
+ returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
+
+rnExpr (SectionL expr op)
+ = rnExpr expr `thenRn4` \ (expr', fvs_expr) ->
+ rnExpr op `thenRn4` \ (op', fvs_op) ->
+ returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
+
+rnExpr (SectionR op expr)
+ = rnExpr op `thenRn4` \ (op', fvs_op) ->
+ rnExpr expr `thenRn4` \ (expr', fvs_expr) ->
+ returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
+
+rnExpr (CCall fun args may_gc is_casm fake_result_ty)
+ = rnExprs args `thenRn4` \ (args', fvs_args) ->
+ returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
+
+rnExpr (HsSCC label expr)
+ = rnExpr expr `thenRn4` \ (expr', fvs_expr) ->
+ returnRn4 (HsSCC label expr', fvs_expr)
+
+rnExpr (HsCase expr ms src_loc)
+ = pushSrcLocRn4 src_loc $
+ rnExpr expr `thenRn4` \ (new_expr, e_fvs) ->
+ mapAndUnzipRn4 rnMatch ms `thenRn4` \ (new_ms, ms_fvs) ->
+ returnRn4 (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs))
+
+rnExpr (HsLet binds expr)
+ = rnBinds binds `thenRn4` \ (binds', fvBinds, new_binders) ->
+ extendSS2 new_binders (rnExpr expr) `thenRn4` \ (expr',fvExpr) ->
+ returnRn4 (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr)
+
+rnExpr (HsDo stmts src_loc)
+ = pushSrcLocRn4 src_loc $
+ rnStmts stmts `thenRn4` \ (stmts', fvStmts) ->
+ returnRn4 (HsDo stmts' src_loc, fvStmts)
+
+rnExpr (ListComp expr quals)
+ = rnQuals quals `thenRn4` \ ((quals', qual_binders), fvQuals) ->
+ extendSS2 qual_binders (rnExpr expr) `thenRn4` \ (expr', fvExpr) ->
+ returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
+
+rnExpr (ExplicitList exps)
+ = rnExprs exps `thenRn4` \ (exps', fvs) ->
+ returnRn4 (ExplicitList exps', fvs)
+
+rnExpr (ExplicitTuple exps)
+ = rnExprs exps `thenRn4` \ (exps', fvExps) ->
+ returnRn4 (ExplicitTuple exps', fvExps)
+
+rnExpr (RecordCon con rbinds)
+ = panic "rnExpr:RecordCon"
+rnExpr (RecordUpd exp rbinds)
+ = panic "rnExpr:RecordUpd"
+
+rnExpr (ExprWithTySig expr pty)
+ = rnExpr expr `thenRn4` \ (expr', fvExpr) ->
+ rnPolyType False nullTyVarNamesEnv pty `thenRn4` \ pty' ->
+ returnRn4 (ExprWithTySig expr' pty', fvExpr)
+
+rnExpr (HsIf p b1 b2 src_loc)
+ = pushSrcLocRn4 src_loc $
+ rnExpr p `thenRn4` \ (p', fvP) ->
+ rnExpr b1 `thenRn4` \ (b1', fvB1) ->
+ rnExpr b2 `thenRn4` \ (b2', fvB2) ->
+ returnRn4 (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2])
+
+rnExpr (ArithSeqIn seq)
+ = rn_seq seq `thenRn4` \ (new_seq, fvs) ->
+ returnRn4 (ArithSeqIn new_seq, fvs)
+ where
+ rn_seq (From expr)
+ = rnExpr expr `thenRn4` \ (expr', fvExpr) ->
+ returnRn4 (From expr', fvExpr)
+
+ rn_seq (FromThen expr1 expr2)
+ = rnExpr expr1 `thenRn4` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenRn4` \ (expr2', fvExpr2) ->
+ returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+
+ rn_seq (FromTo expr1 expr2)
+ = rnExpr expr1 `thenRn4` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenRn4` \ (expr2', fvExpr2) ->
+ returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+
+ rn_seq (FromThenTo expr1 expr2 expr3)
+ = rnExpr expr1 `thenRn4` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenRn4` \ (expr2', fvExpr2) ->
+ rnExpr expr3 `thenRn4` \ (expr3', fvExpr3) ->
+ returnRn4 (FromThenTo expr1' expr2' expr3',
+ unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@Qual@s: in list comprehensions}
+%* *
+%************************************************************************
+
+Note that although some bound vars may appear in the free var set for
+the first qual, these will eventually be removed by the caller. For
+example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
+@[q <- r, p <- q]@, the free var set for @q <- r@ will
+be @{r}@, and the free var set for the entire Quals will be @{r}@. This
+@r@ will be removed only when we finally return from examining all the
+Quals.
+
+\begin{code}
+rnQuals :: [ProtoNameQual]
+ -> Rn4M (([RenamedQual], -- renamed qualifiers
+ [Name]), -- qualifiers' binders
+ FreeVars) -- free variables
+
+rnQuals [qual] -- must be at least one qual
+ = rnQual qual `thenRn4` \ ((new_qual, bs), fvs) ->
+ returnRn4 (([new_qual], bs), fvs)
+
+rnQuals (qual: quals)
+ = rnQual qual `thenRn4` \ ((qual', bs1), fvQuals1) ->
+ extendSS2 bs1 (rnQuals quals) `thenRn4` \ ((quals', bs2), fvQuals2) ->
+ returnRn4
+ ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the
+ -- ones on the left (bs1)
+ fvQuals1 `unionUniqSets` fvQuals2)
+
+rnQual (GeneratorQual pat expr)
+ = rnExpr expr `thenRn4` \ (expr', fvExpr) ->
+ let
+ binders = collectPatBinders pat
+ in
+ getSrcLocRn4 `thenRn4` \ src_loc ->
+ namesFromProtoNames "variable in list-comprehension-generator pattern"
+ (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
+ extendSS new_binders (rnPat pat) `thenRn4` \ pat' ->
+
+ returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr)
+
+rnQual (FilterQual expr)
+ = rnExpr expr `thenRn4` \ (expr', fvs) ->
+ returnRn4 ((FilterQual expr', []), fvs)
+
+rnQual (LetQual binds)
+ = rnBinds binds `thenRn4` \ (binds', binds_fvs, new_binders) ->
+ returnRn4 ((LetQual binds', new_binders), binds_fvs)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{@Stmt@s: in @do@ expressions}
+%* *
+%************************************************************************
+
+\begin{code}
+rnStmts :: [ProtoNameStmt]
+ -> Rn4M ([RenamedStmt], -- renamed qualifiers
+ FreeVars) -- free variables
+
+rnStmts [stmt@(ExprStmt _ _)] -- last stmt must be ExprStmt
+ = rnStmt stmt `thenRn4` \ ((stmt',[]), fvStmt) ->
+ returnRn4 ([stmt'], fvStmt)
+
+rnStmts (stmt:stmts)
+ = rnStmt stmt `thenRn4` \ ((stmt',bs), fvStmt) ->
+ extendSS2 bs (rnStmts stmts) `thenRn4` \ (stmts', fvStmts) ->
+ returnRn4 (stmt':stmts', fvStmt `unionUniqSets` fvStmts)
+
+
+rnStmt (BindStmt pat expr src_loc)
+ = pushSrcLocRn4 src_loc $
+ rnExpr expr `thenRn4` \ (expr', fvExpr) ->
+ let
+ binders = collectPatBinders pat
+ in
+ namesFromProtoNames "variable in do binding"
+ (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
+ extendSS new_binders (rnPat pat) `thenRn4` \ pat' ->
+
+ returnRn4 ((BindStmt pat' expr' src_loc, new_binders), fvExpr)
+
+rnStmt (ExprStmt expr src_loc)
+ =
+ rnExpr expr `thenRn4` \ (expr', fvs) ->
+ returnRn4 ((ExprStmt expr' src_loc, []), fvs)
+
+rnStmt (LetStmt binds)
+ = rnBinds binds `thenRn4` \ (binds', binds_fvs, new_binders) ->
+ returnRn4 ((LetStmt binds', new_binders), binds_fvs)
+
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnHsSyn where
+
+import Ubiq{-uitous-}
+
+import HsSyn
+\end{code}
+
+\begin{code}
+type RenamedArithSeqInfo = ArithSeqInfo Fake Fake Name RenamedPat
+type RenamedBind = Bind Fake Fake Name RenamedPat
+type RenamedClassDecl = ClassDecl Fake Fake Name RenamedPat
+type RenamedClassOpPragmas = ClassOpPragmas Name
+type RenamedClassOpSig = Sig Name
+type RenamedClassPragmas = ClassPragmas Name
+type RenamedConDecl = ConDecl Name
+type RenamedContext = Context Name
+type RenamedDataPragmas = DataPragmas Name
+type RenamedSpecDataSig = SpecDataSig Name
+type RenamedDefaultDecl = DefaultDecl Name
+type RenamedFixityDecl = FixityDecl Name
+type RenamedGRHS = GRHS Fake Fake Name RenamedPat
+type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake Name RenamedPat
+type RenamedGenPragmas = GenPragmas Name
+type RenamedHsBinds = HsBinds Fake Fake Name RenamedPat
+type RenamedHsExpr = HsExpr Fake Fake Name RenamedPat
+type RenamedHsModule = HsModule Fake Fake Name RenamedPat
+type RenamedImportedInterface = ImportedInterface Fake Fake Name RenamedPat
+type RenamedInstDecl = InstDecl Fake Fake Name RenamedPat
+type RenamedInstancePragmas = InstancePragmas Name
+type RenamedInterface = Interface Fake Fake Name RenamedPat
+type RenamedMatch = Match Fake Fake Name RenamedPat
+type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat
+type RenamedMonoType = MonoType Name
+type RenamedPat = InPat Name
+type RenamedPolyType = PolyType Name
+type RenamedQual = Qual Fake Fake Name RenamedPat
+type RenamedSig = Sig Name
+type RenamedSpecInstSig = SpecInstSig Name
+type RenamedStmt = Stmt Fake Fake Name RenamedPat
+type RenamedTyDecl = TyDecl Name
+\end{code}
+
+\begin{code}
+collectQualBinders :: [RenamedQual] -> [Name]
+
+collectQualBinders quals
+ = concat (map collect quals)
+ where
+ collect (GeneratorQual pat _) = collectPatBinders pat
+ collect (FilterQual expr) = []
+ collect (LetQual binds) = collectTopLevelBinders binds
+\end{code}
--- /dev/null
+Breaks the RnPass4/RnExpr4/RnBind4 loops.
+
+\begin{code}
+interface RnLoop where
+
+import Name ( Name )
+import RdrHsSyn ( ProtoNameHsBinds(..), ProtoNamePolyType(..), ProtoNameGenPragmas(..) )
+import RnHsSyn ( RenamedHsBinds(..), RenamedPolyType(..), RenamedGenPragmas(..) )
+import RnBinds4 ( rnBinds, FreeVars(..) )
+import RnMonad4 ( TyVarNamesEnv(..), Rn4M(..) )
+import RnPass4 ( rnPolyType, rnGenPragmas )
+import UniqSet ( UniqSet(..) )
+
+rnBinds :: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name])
+rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
+rnPolyType :: Bool
+ -> TyVarNamesEnv
+ -> ProtoNamePolyType
+ -> Rn4M RenamedPolyType
+
+type FreeVars = UniqSet Name
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[RenameMonad12]{The monad used by the renamer passes 1 and 2}
+\section[RnMonad12]{The monad used by the renamer passes 1 and 2}
\begin{code}
#include "HsVersions.h"
-module RenameMonad12 (
+module RnMonad12 (
Rn12M(..),
initRn12, thenRn12, returnRn12,
mapRn12, zipWithRn12, foldrRn12,
- addErrRn12, getModuleNameRn12, recoverQuietlyRn12,
+ addErrRn12, getModuleNameRn12, recoverQuietlyRn12
-- and to make the interface self-sufficient...
- Bag, Pretty(..), PprStyle, PrettyRep
) where
-import Bag
-import Errors
-import Outputable
-import Pretty -- for type Pretty
-import Util -- for pragmas only
+import Ubiq{-uitous-}
+
+import Bag ( emptyBag, isEmptyBag, snocBag, Bag )
+import ErrUtils ( Error(..) )
+import Pretty ( Pretty(..) )
infixr 9 `thenRn12`
\end{code}
-> Bag Error
-> (result, Bag Error)
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenRn12 #-}
{-# INLINE returnRn12 #-}
-#endif
initRn12 :: FAST_STRING{-module name-} -> Rn12M a -> (a, Bag Error)
initRn12 mod action = action mod emptyBag
= f x y `thenRn12` \ r ->
zipWithRn12 f xs ys `thenRn12` \ rs ->
returnRn12 (r:rs)
+-- NB: zipWithRn12 behaves like zipWithEqual
+-- (requires equal-length lists)
foldrRn12 :: (a -> b -> Rn12M b) -> b -> [a] -> Rn12M b
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[RenameMonad3]{The monad used by the third renamer pass}
+\section[RnMonad3]{The monad used by the third renamer pass}
\begin{code}
#include "HsVersions.h"
-module RenameMonad3 (
+module RnMonad3 (
Rn3M(..),
initRn3, thenRn3, andRn3, returnRn3, mapRn3, fixRn3,
putInfoDownM3,
- newFullNameM3, newInvisibleNameM3,
+ newFullNameM3, newInvisibleNameM3
-- for completeness
- IE, FullName, ExportFlag, ProtoName, Unique,
- SplitUniqSupply
- IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
) where
-import AbsSyn -- including, IE, getIEStrings, ...
-import FiniteMap
-import Maybes ( Maybe(..), assocMaybe )
-import NameTypes
-import Outputable
-import ProtoName
-import RenameMonad4 ( GlobalNameFun(..) )
-import SplitUniq
-import Unique
-import Util
+import Ubiq{-uitous-}
+
+import FiniteMap ( emptyFM, isEmptyFM, lookupFM,
+ emptySet, isEmptySet, elementOf
+ )
+import HsSyn ( IE )
+import NameTypes -- lots of stuff
+import Outputable ( ExportFlag(..) )
+import ProtoName ( ProtoName(..) )
+import RdrHsSyn ( getExportees, ExportListInfo(..), ProtoNameIE(..) )
+import UniqSupply ( getUnique, splitUniqSupply )
+import Util ( panic )
infixr 9 `thenRn3`
\end{code}
%************************************************************************
%* *
-\subsection{Plain @Rename3@ monadery}
+\subsection{Plain @RnPass3@ monadery}
%* *
%************************************************************************
\begin{code}
type Rn3M result
- = ImExportListInfo -> FAST_STRING{-ModuleName-} -> SplitUniqSupply
+ = ExportListInfo -> FAST_STRING{-ModuleName-} -> UniqSupply
-> result
-#ifdef __GLASGOW_HASKELL__
{-# INLINE andRn3 #-}
{-# INLINE thenRn3 #-}
{-# INLINE returnRn3 #-}
-#endif
-initRn3 :: Rn3M a -> SplitUniqSupply -> a
+initRn3 :: Rn3M a -> UniqSupply -> a
-initRn3 m us = m (emptyFM,emptySet) (panic "initRn3: uninitialised module name") us
+initRn3 m us = m Nothing{-no export list-} (panic "initRn3: uninitialised module name") us
thenRn3 :: Rn3M a -> (a -> Rn3M b) -> Rn3M b
andRn3 :: (a -> a -> a) -> Rn3M a -> Rn3M a -> Rn3M a
where
result = m result exps mod_name us
-putInfoDownM3 :: FAST_STRING{-ModuleName-} -> [IE] -> Rn3M a -> Rn3M a
+putInfoDownM3 :: FAST_STRING{-ModuleName-} -> Maybe [ProtoNameIE] -> Rn3M a -> Rn3M a
putInfoDownM3 mod_name exports cont _ _ uniqs
- = cont (getIEStrings exports) mod_name uniqs
+ = cont (getExportees exports) mod_name uniqs
\end{code}
%************************************************************************
%* *
-\subsection[RenameMonad3-new-names]{Making new names}
+\subsection[RnMonad3-new-names]{Making new names}
%* *
%************************************************************************
new_name pn src_loc is_tycon_ish frcd_export_flag want_invisible exps mod_name uniqs
= (uniq, name)
where
- uniq = getSUnique uniqs
+ uniq = getUnique uniqs
mk_name = if want_invisible then mkPrivateFullName else mkFullName
name = case pn of
- Unk s -> mk_name mod_name s
- (if fromPrelude mod_name
- && is_tycon_ish then -- & tycon/clas/datacon => Core
- HereInPreludeCore
- else
- ThisModule
- )
- (case frcd_export_flag of
- Just fl -> fl
- Nothing -> mk_export_flag True [mod_name] s exps)
- src_loc
+ Unk s -> mk_name mod_name s
+ (if fromPrelude mod_name
+ && is_tycon_ish then -- & tycon/clas/datacon => Core
+ HereInPreludeCore
+ else
+ ThisModule
+ )
+ (case frcd_export_flag of
+ Just fl -> fl
+ Nothing -> mk_export_flag True [mod_name] s exps)
+ src_loc
+
+ Qunk m s -> mk_name mod_name s
+ (if fromPrelude mod_name
+ && is_tycon_ish then -- & tycon/clas/datacon => Core
+ HereInPreludeCore
+ else
+ ThisModule
+ )
+ (case frcd_export_flag of
+ Just fl -> fl
+ Nothing -> mk_export_flag (_trace "mk_export_flag?" True) [m] s exps)
+ src_loc
-- note: the assigning of prelude-ness is most dubious (ToDo)
OtherModule l informant_mods -- for Other*, we save its occurrence name
)
(case frcd_export_flag of
- Just fl -> fl
+ Just fl -> fl
Nothing -> mk_export_flag (m==mod_name) informant_mods l exps)
src_loc
- Prel n -> panic "RenameMonad3.new_name: prelude name"
+ Prel n -> panic "RnMonad3.new_name: prelude name"
\end{code}
In deciding the ``exportness'' of something, there are these cases to
\begin{code}
mk_export_flag :: Bool -- True <=> originally from the module we're compiling
- -> [FAST_STRING] -- modules that told us about this thing
+ -> [FAST_STRING]-- modules that told us about this thing
-> FAST_STRING -- name of the thing we're looking at
- -> ImExportListInfo
+ -> ExportListInfo
-> ExportFlag -- result
-mk_export_flag this_module informant_mods thing (exports_alist, dotdot_modules)
- | isEmptyFM exports_alist && isEmptySet dotdot_modules
+mk_export_flag this_module informant_mods thing Nothing{-no export list-}
= if this_module then ExportAll else NotExported
+mk_export_flag this_module informant_mods thing (Just (exports_alist, dotdot_modules))
| otherwise
= case (lookupFM exports_alist thing) of
Just how_to_export -> how_to_export
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[RenameMonad4]{The monad used by the fourth renamer pass}
+\section[RnMonad4]{The monad used by the fourth renamer pass}
\begin{code}
#include "HsVersions.h"
-module RenameMonad4 (
+module RnMonad4 (
Rn4M(..),
initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4,
addErrRn4, failButContinueRn4, recoverQuietlyRn4,
pushSrcLocRn4,
getSrcLocRn4,
- getSwitchCheckerRn4,
lookupValue, lookupValueEvenIfInvisible,
lookupClassOp, lookupFixityOp,
lookupTyCon, lookupTyConEvenIfInvisible,
namesFromProtoNames,
TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
- lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
+ lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
-- for completeness
- Module, Bag, RenamedPat(..), InPat, Maybe, Name, Error(..),
- Pretty(..), PprStyle, PrettyRep, ProtoName, GlobalSwitch,
- GlobalNameFun(..), GlobalNameFuns(..), UniqSet(..), UniqFM, SrcLoc,
- Unique, SplitUniqSupply
- IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-import Outputable
+import Ubiq{-uitous-}
-import AbsSyn
-import Bag
-import CmdLineOpts ( GlobalSwitch(..) )
-import Errors ( dupNamesErr, unknownNameErr, shadowedNameErr,
- badClassOpErr, Error(..)
- )
-import FiniteMap ( lookupFM, addToFM, addListToFM, emptyFM, FiniteMap )
-import Maybes ( Maybe(..), assocMaybe )
-import Name ( isTyConName, isClassName, isClassOpName,
- isUnboundName, invisibleName
+import Bag ( emptyBag, isEmptyBag, unionBags, snocBag, Bag )
+import CmdLineOpts ( opt_ShowPragmaNameErrs, opt_NameShadowingNotOK )
+import ErrUtils
+import FiniteMap ( emptyFM, addListToFM, addToFM, lookupFM )
+import Name ( invisibleName, isTyConName, isClassName,
+ isClassOpName, isUnboundName, Name(..)
)
-import NameTypes ( mkShortName, ShortName )
-import ProtoName -- lots of stuff
-import RenameAuxFuns -- oh, why not ... all of it
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import SplitUniq
-import UniqSet
-import Unique
-import Util
+import NameTypes ( mkShortName, ShortName{-instances-} )
+import Outputable ( pprNonOp )
+import Pretty
+import ProtoName ( eqProtoName, cmpByLocalName, ProtoName(..) )
+import RnUtils ( dupNamesErr, GlobalNameMappers(..) )
+import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instance-} )
+import UniqSet ( mkUniqSet, minusUniqSet, UniqSet(..) )
+import UniqSupply ( getUniques, splitUniqSupply )
+import Util ( assoc, removeDups, zipWithEqual, panic )
infixr 9 `thenRn4`, `thenRn4_`
\end{code}
%************************************************************************
%* *
-\subsection[RenameMonad]{Plain @Rename@ monadery}
+\subsection[RnMonad4]{Plain @Rename@ monadery for pass~4}
%* *
%************************************************************************
type ScopeStack = FiniteMap FAST_STRING Name
type Rn4M result
- = (GlobalSwitch -> Bool)
- -> GlobalNameFuns
+ = GlobalNameMappers
-> ScopeStack
-> Bag Error
- -> SplitUniqSupply
+ -> UniqSupply
-> SrcLoc
-> (result, Bag Error)
-#ifdef __GLASGOW_HASKELL__
{-# INLINE andRn4 #-}
{-# INLINE thenRn4 #-}
{-# INLINE thenLazilyRn4 #-}
{-# INLINE thenRn4_ #-}
{-# INLINE returnRn4 #-}
-#endif
-initRn4 :: (GlobalSwitch -> Bool)
- -> GlobalNameFuns
+initRn4 :: GlobalNameMappers
-> Rn4M result
- -> SplitUniqSupply
+ -> UniqSupply
-> (result, Bag Error)
-initRn4 sw_chkr gnfs renamer init_us
- = renamer sw_chkr gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
+initRn4 gnfs renamer init_us
+ = renamer gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
thenRn4, thenLazilyRn4
:: Rn4M a -> (a -> Rn4M b) -> Rn4M b
thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b
andRn4 :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a
-thenRn4 expr cont sw_chkr gnfs ss errs uniqs locn
- = case (splitUniqSupply uniqs) of { (s1, s2) ->
- case (expr sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) ->
- case (cont res1 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
+thenRn4 expr cont gnfs ss errs uniqs locn
+ = case (splitUniqSupply uniqs) of { (s1, s2) ->
+ case (expr gnfs ss errs s1 locn) of { (res1, errs1) ->
+ case (cont res1 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
(res2, errs2) }}}
-thenLazilyRn4 expr cont sw_chkr gnfs ss errs uniqs locn
+thenLazilyRn4 expr cont gnfs ss errs uniqs locn
= let
(s1, s2) = splitUniqSupply uniqs
- (res1, errs1) = expr sw_chkr gnfs ss errs s1 locn
- (res2, errs2) = cont res1 sw_chkr gnfs ss errs1 s2 locn
+ (res1, errs1) = expr gnfs ss errs s1 locn
+ (res2, errs2) = cont res1 gnfs ss errs1 s2 locn
in
(res2, errs2)
-thenRn4_ expr cont sw_chkr gnfs ss errs uniqs locn
- = case (splitUniqSupply uniqs) of { (s1, s2) ->
- case (expr sw_chkr gnfs ss errs s1 locn) of { (_, errs1) ->
- case (cont sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
+thenRn4_ expr cont gnfs ss errs uniqs locn
+ = case (splitUniqSupply uniqs) of { (s1, s2) ->
+ case (expr gnfs ss errs s1 locn) of { (_, errs1) ->
+ case (cont gnfs ss errs1 s2 locn) of { (res2, errs2) ->
(res2, errs2) }}}
-andRn4 combiner m1 m2 sw_chkr gnfs ss errs us locn
- = case (splitUniqSupply us) of { (s1, s2) ->
- case (m1 sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) ->
- case (m2 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
+andRn4 combiner m1 m2 gnfs ss errs us locn
+ = case (splitUniqSupply us) of { (s1, s2) ->
+ case (m1 gnfs ss errs s1 locn) of { (res1, errs1) ->
+ case (m2 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
(combiner res1 res2, errs2) }}}
returnRn4 :: a -> Rn4M a
-returnRn4 result sw_chkr gnfs ss errs_so_far uniqs locn
+returnRn4 result gnfs ss errs_so_far uniqs locn
= (result, errs_so_far)
failButContinueRn4 :: a -> Error -> Rn4M a
-failButContinueRn4 res err sw_chkr gnfs ss errs_so_far uniqs locn
+failButContinueRn4 res err gnfs ss errs_so_far uniqs locn
= (res, errs_so_far `snocBag` err)
addErrRn4 :: Error -> Rn4M ()
-addErrRn4 err sw_chkr gnfs ss errs_so_far uniqs locn
+addErrRn4 err gnfs ss errs_so_far uniqs locn
= ((), errs_so_far `snocBag` err)
\end{code}
\begin{code}
recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a
-recoverQuietlyRn4 use_this_if_err action sw_chkr gnfs ss errs_so_far uniqs locn
+recoverQuietlyRn4 use_this_if_err action gnfs ss errs_so_far uniqs locn
= let
(result, errs_out)
- = case (action sw_chkr gnfs ss emptyBag{-leav out errs-} uniqs locn) of
+ = case (action gnfs ss emptyBag{-leav out errs-} uniqs locn) of
(result1, errs1) ->
if isEmptyBag errs1 then -- all's well! (but retain incoming errs)
(result1, errs_so_far)
else -- give up; return *incoming* UniqueSupply...
(use_this_if_err,
- if sw_chkr ShowPragmaNameErrs
+ if opt_ShowPragmaNameErrs
then errs_so_far `unionBags` errs1
else errs_so_far) -- toss errs, otherwise
in
\begin{code}
pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a
-pushSrcLocRn4 locn exp sw_chkr gnfs ss errs_so_far uniq_supply old_locn
- = exp sw_chkr gnfs ss errs_so_far uniq_supply locn
+pushSrcLocRn4 locn exp gnfs ss errs_so_far uniq_supply old_locn
+ = exp gnfs ss errs_so_far uniq_supply locn
getSrcLocRn4 :: Rn4M SrcLoc
-getSrcLocRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
- = returnRn4 locn sw_chkr gnfs ss errs_so_far uniq_supply locn
-
-getSwitchCheckerRn4 :: Rn4M (GlobalSwitch -> Bool)
-
-getSwitchCheckerRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
- = returnRn4 sw_chkr sw_chkr gnfs ss errs_so_far uniq_supply locn
+getSrcLocRn4 gnfs ss errs_so_far uniq_supply locn
+ = returnRn4 locn gnfs ss errs_so_far uniq_supply locn
\end{code}
\begin{code}
getNextUniquesFromRn4 :: Int -> Rn4M [Unique]
-getNextUniquesFromRn4 n sw_chkr gnfs ss errs_so_far us locn
- = case (getSUniques n us) of { next_uniques ->
+getNextUniquesFromRn4 n gnfs ss errs_so_far us locn
+ = case (getUniques n us) of { next_uniques ->
(next_uniques, errs_so_far) }
\end{code}
\begin{code}
namesFromProtoNames :: String -- Documentation string
-> [(ProtoName, SrcLoc)]
- -> Rn4M [Name]
+ -> Rn4M [Name]
-namesFromProtoNames kind pnames_w_src_loc sw_chkr gnfs ss errs_so_far us locn
+namesFromProtoNames kind pnames_w_src_loc gnfs ss errs_so_far us locn
= (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_`
mkNewNames goodies
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
where
(goodies, dups) = removeDups cmp pnames_w_src_loc
- -- We want to compare their local names rather than their
+ -- We want to compare their local names rather than their
-- full protonames. It probably doesn't matter here, but it
- -- does in Rename3.lhs!
+ -- does in RnPass3.lhs!
cmp (a, _) (b, _) = cmpByLocalName a b
\end{code}
@mkNewNames@ assumes the names are unique.
\begin{code}
-mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]
+mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]
mkNewNames pnames_w_locs
= getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs ->
- returnRn4 (zipWith new_short_name uniqs pnames_w_locs)
+ returnRn4 (zipWithEqual new_short_name uniqs pnames_w_locs)
where
new_short_name uniq (Unk str, srcloc) -- gotta be an Unk...
= Short uniq (mkShortName str srcloc)
unboundName pn
= Unbound (grab_string pn)
where
- grab_string (Unk s) = s
+ grab_string (Unk s) = s
+ grab_string (Qunk _ s) = s
grab_string (Imp _ _ _ s) = s
\end{code}
@lookup_val@ is the help function to do the work.
\begin{code}
-lookupValue v {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+lookupValue v {-Rn4-} gnfs ss errs_so_far us locn
= (lookup_val v `thenLazilyRn4` \ name ->
if invisibleName name
then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc)
else returnRn4 name
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
lookupValueEvenIfInvisible v = lookup_val v
lookup_val :: ProtoName -> Rn4M Name
-lookup_val pname@(Unk v) sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookup_val pname@(Unk v) gnfs@(v_gnf, tc_gnf) ss a b locn
= case (lookupFM ss v) of
- Just name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name -> returnRn4 name gnfs ss a b locn
Nothing -> case (v_gnf pname) of
- Just name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name -> returnRn4 name gnfs ss a b locn
Nothing -> failButContinueRn4 (unboundName pname)
(unknownNameErr "value" pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
+
+lookup_val (Qunk _ _) _ _ _ _ _ = panic "RnMonad4:lookup_val:Qunk"
-- If it ain't an Unk it must be in the global name fun; that includes
-- prelude things.
-lookup_val pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookup_val pname gnfs@(v_gnf, tc_gnf) ss a b locn
= case (v_gnf pname) of
- Just name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name -> returnRn4 name gnfs ss a b locn
Nothing -> failButContinueRn4 (unboundName pname)
(unknownNameErr "value" pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
\end{code}
Looking up the operators in a fixity decl is done differently. We
so we nuke those, too.
\begin{code}
-lookupFixityOp (Prel _) sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing sw_chkr gnfs
-lookupFixityOp pname sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) sw_chkr gnfs
+lookupFixityOp (Prel _) gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing gnfs
+lookupFixityOp pname gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) gnfs
\end{code}
\begin{code}
lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name
-- The global name funs handle Prel things
-lookupTyCon tc {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+lookupTyCon tc {-Rn4-} gnfs ss errs_so_far us locn
= (lookup_tycon tc `thenLazilyRn4` \ name ->
if invisibleName name
then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc)
else returnRn4 name
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
lookupTyConEvenIfInvisible tc = lookup_tycon tc
-lookup_tycon (Prel name) sw_chkr gnfs ss a b locn = returnRn4 name sw_chkr gnfs ss a b locn
+lookup_tycon (Prel name) gnfs ss a b locn = returnRn4 name gnfs ss a b locn
-lookup_tycon pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookup_tycon pname gnfs@(v_gnf, tc_gnf) ss a b locn
= case (tc_gnf pname) of
- Just name | isTyConName name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name | isTyConName name -> returnRn4 name gnfs ss a b locn
_ -> failButContinueRn4 (unboundName pname)
(unknownNameErr "type constructor" pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
\end{code}
\begin{code}
lookupClass :: ProtoName -> Rn4M Name
-lookupClass pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookupClass pname gnfs@(v_gnf, tc_gnf) ss a b locn
= case (tc_gnf pname) of
- Just name | isClassName name -> returnRn4 name sw_chkr gnfs ss a b locn
+ Just name | isClassName name -> returnRn4 name gnfs ss a b locn
_ -> failButContinueRn4 (unboundName pname)
(unknownNameErr "class" pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
\end{code}
@lookupClassOp@ is used when looking up the lhs identifiers in a class
\begin{code}
lookupClassOp :: Name -> ProtoName -> Rn4M Name
-lookupClassOp class_name pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
+lookupClassOp class_name pname gnfs@(v_gnf, tc_gnf) ss a b locn
= case v_gnf pname of
Just op_name | isClassOpName class_name op_name
|| isUnboundName class_name -- avoid spurious errors
- -> returnRn4 op_name sw_chkr gnfs ss a b locn
+ -> returnRn4 op_name gnfs ss a b locn
other -> failButContinueRn4 (unboundName pname)
(badClassOpErr class_name pname locn)
- sw_chkr gnfs ss a b locn
+ gnfs ss a b locn
\end{code}
@extendSS@ extends the scope; @extendSS2@ also removes the newly bound
-> Rn4M a
-> Rn4M a
-extendSS binders expr sw_chkr gnfs ss errs us locn
- = case (extend binders ss sw_chkr gnfs ss errs us locn) of { (new_ss, new_errs) ->
- expr sw_chkr gnfs new_ss new_errs us locn }
+extendSS binders expr gnfs ss errs us locn
+ = case (extend binders ss gnfs ss errs us locn) of { (new_ss, new_errs) ->
+ expr gnfs new_ss new_errs us locn }
where
extend :: [Name] -> ScopeStack -> Rn4M ScopeStack
extend names ss
- = if (sw_chkr NameShadowingNotOK) then
+ = if opt_NameShadowingNotOK then
hard_way names ss
else -- ignore shadowing; blast 'em in
returnRn4 (
-> Rn4M (a, UniqSet Name)
-> Rn4M (a, UniqSet Name)
-extendSS2 binders expr sw_chkr gnfs ss errs_so_far us locn
- = case (extendSS binders expr sw_chkr gnfs ss errs_so_far us locn) of
+extendSS2 binders expr gnfs ss errs_so_far us locn
+ = case (extendSS binders expr gnfs ss errs_so_far us locn) of
((e2, freevars), errs)
-> ((e2, freevars `minusUniqSet` (mkUniqSet binders)),
errs)
mkTyVarNamesEnv
:: SrcLoc
-> [ProtoName] -- The type variables
- -> Rn4M (TyVarNamesEnv,[Name]) -- Environment and renamed tyvars
+ -> Rn4M (TyVarNamesEnv,[Name]) -- Environment and renamed tyvars
-mkTyVarNamesEnv src_loc tyvars {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+mkTyVarNamesEnv src_loc tyvars {-Rn4-} gnfs ss errs_so_far us locn
= (namesFromProtoNames "type variable"
(tyvars `zip` repeat src_loc) `thenRn4` \ tyvars2 ->
tyvars2_in_orig_order = map snd tv_env
in
returnRn4 (tv_env, tyvars2_in_orig_order)
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
where
extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)]
extend [] ss = ss
\begin{code}
lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name
-lookupTyVarName env pname {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+lookupTyVarName env pname {-Rn4-} gnfs ss errs_so_far us locn
= (case (assoc_maybe env pname) of
Just name -> returnRn4 name
Nothing -> getSrcLocRn4 `thenRn4` \ loc ->
failButContinueRn4 (unboundName pname)
(unknownNameErr "type variable" pname loc)
- ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
+ ) {-Rn4-} gnfs ss errs_so_far us locn
where
assoc_maybe [] _ = Nothing
assoc_maybe ((tv,xxx) : tvs) key
= if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
+
+\begin{code}
+badClassOpErr clas op locn
+ = addErrLoc locn "" ( \ sty ->
+ ppBesides [ppChar '`', pprNonOp sty op, ppStr "' is not an operation of class `",
+ ppr sty clas, ppStr "'."] )
+
+----------------------------
+-- dupNamesErr: from RnUtils
+
+---------------------------
+shadowedNameErr shadow locn
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "more than one value with the same name (shadowing): ",
+ ppr sty shadow] )
+
+------------------------------------------
+unknownNameErr descriptor undef_thing locn
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ",
+ pprNonOp sty undef_thing] )
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[Rename1]{@Rename1@: gather up imported information}
+\section[RnPass1]{@RnPass1@: gather up imported information}
See the @Rename@ module for a basic description of the renamer.
\begin{code}
#include "HsVersions.h"
-module Rename1 (
- rnModule1,
+module RnPass1 (
+ rnModule1
-- for completeness
- Module, Bag, ProtoNamePat(..), InPat, Maybe,
- PprStyle, Pretty(..), PrettyRep, ProtoName, Name,
- PreludeNameFun(..), PreludeNameFuns(..)
) where
-IMPORT_Trace -- ToDo: rm
-import Pretty -- these two too
-import Outputable
-
-import AbsSyn
-import AbsSynFuns ( getMentionedVars ) -- *** not via AbsSyn ***
-import Bag ( Bag, emptyBag, unitBag, snocBag, unionBags, bagToList )
-import Errors
-import HsPragmas
-import FiniteMap
-import Maybes ( maybeToBool, catMaybes, Maybe(..) )
---OLD: import NameEnv ( mkStringLookupFn )
-import ProtoName ( ProtoName(..), mkPreludeProtoName )
-import RenameAuxFuns
-import RenameMonad12
-import Util
+import Ubiq{-uitous-}
+
+import HsSyn
+import HsPragmas ( DataPragmas(..) )
+import RdrHsSyn -- ProtoName* instantiations...
+
+import Bag ( emptyBag, unitBag, snocBag, unionBags, Bag )
+import ErrUtils
+import FiniteMap ( lookupFM, listToFM, elementOf )
+import Maybes ( catMaybes, maybeToBool )
+import Name ( Name{-instances-} )
+import Outputable ( isAvarid, getLocalName, interpp'SP )
+import PprStyle ( PprStyle(..) )
+import Pretty
+import ProtoName ( mkPreludeProtoName, ProtoName(..) )
+import RnMonad12
+import RnUtils
+import Util ( lengthExceeds, panic )
\end{code}
-
%************************************************************************
%* *
\subsection{Types and things used herein}
data Wantedness
= Wanted
| NotWanted
- | WantedWith IE
+ | WantedWith (IE ProtoName)
\end{code}
The @ProtoNames@ supplied to these ``name functions'' are always
@Unks@, unless they are fully-qualified names, which occur only in
interface pragmas (and, therefore, never on the {\em definitions} of
-things). That doesn't happen in @Rename1@!
+things). That doesn't happen in @RnPass1@!
\begin{code}
type IntNameFun = ProtoName -> ProtoName
type IntTCNameFun = ProtoName -> (ProtoName, IntNameFun)
unused ones.
\begin{code}
-rnModule1 :: PreludeNameFuns
+rnModule1 :: PreludeNameMappers
-> Bool -- see use below
- -> ProtoNameModule
- -> Rn12M (ProtoNameModule, [FAST_STRING])
+ -> ProtoNameHsModule
+ -> Rn12M (ProtoNameHsModule, Bag FAST_STRING)
rnModule1 pnf@(v_pnf, tc_pnf)
use_mentioned_vars_heuristic
- (Module mod_name exports imports fixes
- ty_decls absty_sigs class_decls inst_decls specinst_sigs
- defaults binds _ src_loc)
+ (HsModule mod_name exports imports fixes
+ ty_decls absty_sigs class_decls inst_decls specinst_sigs
+ defaults binds _ src_loc)
= -- slurp through the *body* of the module, collecting names of
-- mentioned *variables*, 3+ letters long & not prelude names.
-- Note: we *do* have to pick up top-level binders,
-- so we can check for conflicts with imported guys!
let
-{- OLD:MENTIONED-}
+ is_mentioned_fn = \ x -> True -- wimp way out
+{- OLD:
(uses_Mdotdot_in_exports, mentioned_vars)
= getMentionedVars v_pnf exports fixes class_decls inst_decls binds
-- us this, and we act accordingly.
is_mentioned_maybe
- = lookupFM {-OLD: mkStringLookupFn-} (listToFM
+ = lookupFM (listToFM
[ (x, panic "is_mentioned_fn")
| x <- mentioned_vars ++ needed_for_deriving ]
)
- -- OLD: False{-not-sorted-}
where
needed_for_deriving -- is this a HACK or what?
= [ SLIT("&&"),
&& not (uses_Mdotdot_in_exports)
then \ x -> maybeToBool (is_mentioned_maybe x)
else \ x -> True
-{- OLD:MENTIONED-}
---O:M is_mentioned_fn = \ x -> True -- ToDo: delete altogether
+-}
in
-- OK, now do the business:
doImportedIfaces pnf is_mentioned_fn imports
inst_decls' = doRevoltingInstDecls tc_nf inst_decls
in
returnRn12
- ((Module mod_name
- exports imports -- passed along mostly for later checking
- (int_fixes ++ fixes)
- (int_ty_decls ++ ty_decls)
- absty_sigs
- (int_class_decls ++ class_decls)
- (int_inst_decls ++ inst_decls')
- specinst_sigs
- defaults
- binds
- int_sigs
- src_loc),
- bagToList import_names)
+ ((HsModule mod_name
+ exports imports -- passed along mostly for later checking
+ (int_fixes ++ fixes)
+ (int_ty_decls ++ ty_decls)
+ absty_sigs
+ (int_class_decls ++ class_decls)
+ (int_inst_decls ++ inst_decls')
+ specinst_sigs
+ defaults
+ binds
+ int_sigs
+ src_loc),
+ import_names)
where
-- This function just spots prelude names
tc_nf pname@(Unk s) = case (tc_pnf s) of
doRevoltingInstDecls tc_nf decls
= map revolt_me decls
where
- revolt_me (InstDecl context cname ty binds True modname imod uprags pragma src_loc)
+ revolt_me (InstDecl cname ty binds True modname uprags pragma src_loc)
= InstDecl
- context -- Context unchanged
(tc_nf cname) -- Look up the class
- (doIfaceMonoType1 tc_nf ty) -- Ditto the type
+ (doIfacePolyType1 tc_nf ty) -- Ditto the type
binds -- Binds unchanged
- True
+ True{-yes,defined in this module-}
modname
- imod
uprags
pragma
src_loc
module being renamed.
\begin{code}
-doImportedIfaces :: PreludeNameFuns
+doImportedIfaces :: PreludeNameMappers
-> (FAST_STRING -> Bool)
-> [ProtoNameImportedInterface]
-> Rn12M AllIntDecls
\end{code}
\begin{code}
-doOneIface pnfs is_mentioned_fn (ImportAll int renamings)
- = let
- renaming_fn = mkRenamingFun renamings
- -- if there are any renamings, then we don't use
- -- the "is_mentioned_fn" hack; possibly dangerous (paranoia reigns)
- revised_is_mentioned_fn
- = if null renamings
- then is_mentioned_fn
- else (\ x -> True) -- pretend everything is mentioned
- in
--- pprTrace "ImportAll:mod_rns:" (ppr PprDebug renamings) (
- doIface1 renaming_fn pnfs (selectAll renaming_fn revised_is_mentioned_fn) int
--- )
-
-doOneIface pnfs unused_is_mentioned_fn (ImportSome int ie_list renamings)
- = --pprTrace "ImportSome:mod_rns:" (ppr PprDebug renamings) (
- doIface1 (mkRenamingFun renamings) pnfs si_fun int
- --)
+doOneIface :: PreludeNameMappers
+ -> (FAST_STRING -> Bool)
+ -> ProtoNameImportedInterface
+ -> Rn12M AllIntDecls
+
+doOneIface _ _ (ImportMod _ True{-qualified-} _ _)
+ = panic "RnPass1.doOneIface:can't grok `qualified'"
+
+doOneIface _ _ (ImportMod _ _ (Just _) _)
+ = panic "RnPass1.doOneIface:can't grok `as' module (blech)"
+
+doOneIface pnfs is_mentioned_fn (ImportMod iface qual asmod Nothing{-all-})
+ = doIface1 pnfs (selectAll is_mentioned_fn) iface
+
+doOneIface pnfs _ (ImportMod iface qual asmod (Just (False{-unhidden-}, ies)))
+ = doIface1 pnfs si_fun iface
where
-- the `selective import' function should not be applied
-- to the Imps that occur on Ids in unfoldings.
- si_fun (Unk str) = check_ie str ie_list
- si_fun other = panic "si_fun in doOneIface"
+ si_fun (Unk n) = check_ie n ies
+ si_fun (Qunk _ n) = check_ie n ies
check_ie name [] = NotWanted
check_ie name (ie:ies)
= case ie of
- IEVar n | name == n -> Wanted
- IEThingAbs n | name == n -> WantedWith ie
- IEThingAll n | name == n -> WantedWith ie
- IEConWithCons n ns | name == n -> WantedWith ie
- IEClsWithOps n ns | name == n -> WantedWith ie
- IEModuleContents _ -> panic "Module.. in import list?"
- other -> check_ie name ies
-
-doOneIface pnfs unused_is_mentioned_fn (ImportButHide int ie_list renamings)
- = --pprTrace "ImportButHide:mod_rns:" (ppr PprDebug renamings) (
- doIface1 (mkRenamingFun renamings) pnfs si_fun int
- --)
+ IEVar (Unk n) | name == n -> Wanted
+ IEThingAbs (Unk n) | name == n -> WantedWith ie
+ IEThingAll (Unk n) | name == n -> WantedWith ie
+ IEModuleContents _ -> panic "Module.. in import list?"
+ other -> check_ie name ies
+
+doOneIface pnfs _ (ImportMod iface qual asmod (Just (True{-hidden-}, ies)))
+ = doIface1 pnfs si_fun iface
where
-- see comment above:
- si_fun (Unk str) | str `elemFM` entity_info = NotWanted
- | otherwise = Wanted
+ si_fun x | n `elementOf` entity_info = NotWanted
+ | otherwise = Wanted
+ where
+ n = case x of { Unk s -> s; Qunk _ s -> s }
- entity_info = fst (getIEStrings ie_list)
+ entity_info = getImportees ies
\end{code}
@selectAll@ ``normally'' creates an @SelectiveImporter@ that declares
quite happy to throw away short names that aren't mentioned?
\begin{code}
-selectAll :: (FAST_STRING -> FAST_STRING) -> (FAST_STRING -> Bool) -> SelectiveImporter
+selectAll :: (FAST_STRING -> Bool) -> SelectiveImporter
-selectAll renaming_fn is_mentioned_fn (Unk str) -- gotta be an Unk
+selectAll is_mentioned_fn n
= let
- rn_str = renaming_fn str
+ rn_str = case n of { Unk s -> s ; Qunk _ s -> s }
in
if (isAvarid rn_str)
&& (not (is_mentioned_fn rn_str))
be described at its definition.
\begin{code}
-doIface1 :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module
- -> PreludeNameFuns
- -> SelectiveImporter
- -> ProtoNameInterface
- -> Rn12M AllIntDecls
-
-doIface1 mod_rn_fn (v_pnf, tc_pnf) sifun
- (MkInterface i_name import_decls fix_decls ty_decls class_decls
+doIface1 :: PreludeNameMappers
+ -> SelectiveImporter
+ -> ProtoNameInterface
+ -> Rn12M AllIntDecls
+
+doIface1 (v_pnf, tc_pnf) sifun
+ (Interface i_name import_decls fix_decls ty_decls class_decls
inst_decls sig_decls anns)
- = doIfaceImports1 mod_rn_fn i_name import_decls `thenRn12` \ (v_bag, tc_bag) ->
+ = doIfaceImports1 (panic "i_name"{-i_name-}) import_decls `thenRn12` \ (v_bag, tc_bag) ->
do_body (v_bag, tc_bag)
where
do_body (v_bag, tc_bag)
= report_all_errors `thenRn12` \ _ ->
- doIfaceTyDecls1 sifun full_tc_nf ty_decls `thenRn12` \ ty_decls' ->
+ doIfaceTyDecls1 sifun full_tc_nf ty_decls `thenRn12` \ ty_decls' ->
doIfaceClassDecls1 sifun full_tc_nf class_decls `thenRn12` \ class_decls' ->
- let sig_decls' = doIfaceSigs1 sifun v_nf tc_nf sig_decls
- fix_decls' = doIfaceFixes1 sifun v_nf fix_decls
- inst_decls' = doIfaceInstDecls1 sifun tc_nf inst_decls
+ let sig_decls' = doIfaceSigs1 sifun v_nf tc_nf sig_decls
+ fix_decls' = doIfaceFixes1 sifun v_nf fix_decls
+ inst_decls' = doIfaceInstDecls1 sifun tc_nf inst_decls
in
returnRn12 (fix_decls', ty_decls', class_decls', inst_decls', sig_decls', unitBag i_name)
where
v_dups :: [[(FAST_STRING, ProtoName)]]
tc_dups :: [[(FAST_STRING, (ProtoName, IntNameFun))]]
- (imp_v_nf, v_dups) = mkNameFun {-OLD:v_pnf-} v_bag
- (imp_tc_nf, tc_dups) = mkNameFun {-OLD:tc_pnf-} tc_bag
+ (imp_v_nf, v_dups) = mkNameFun v_bag
+ (imp_tc_nf, tc_dups) = mkNameFun tc_bag
v_nf :: IntNameFun
v_nf (Unk s) = case v_pnf s of
Just n -> mkPreludeProtoName n
Nothing -> case imp_v_nf s of
Just n -> n
- Nothing -> Imp i_name s [i_name] (mod_rn_fn s)
+ Nothing -> Imp i_name s [i_name] s
+ -- used for (..)'d parts of prelude datatype/class decls
prel_con_or_op_nf :: FAST_STRING{-module name-}-> IntNameFun
- -- Used for (..)'d parts of prelude datatype/class decls;
- -- OLD:? For `data' types, we happen to know everything;
- -- OLD:? For class decls, we *don't* know what the class-ops are.
prel_con_or_op_nf m (Unk s)
= case v_pnf s of
Just n -> mkPreludeProtoName n
- Nothing -> Imp m s [m] (mod_rn_fn s)
+ Nothing -> Imp m s [m] s
-- Strictly speaking, should be *no renaming* here, folks
- local_con_or_op_nf :: IntNameFun
- -- used for non-prelude constructors/ops
- local_con_or_op_nf (Unk s) = Imp i_name s [i_name] (mod_rn_fn s)
+ -- used for non-prelude constructors/ops/fields
+ local_con_or_op_nf :: IntNameFun
+ local_con_or_op_nf (Unk s) = Imp i_name s [i_name] s
full_tc_nf :: IntTCNameFun
full_tc_nf (Unk s)
Nothing -> case imp_tc_nf s of
Just pair -> pair
- Nothing -> (Imp i_name s [i_name] (mod_rn_fn s),
- local_con_or_op_nf)
+ Nothing -> (Imp i_name s [i_name] s,
+ local_con_or_op_nf)
tc_nf = fst . full_tc_nf
- -- ADR: commented out next new lines because I don't believe
- -- ADR: the check is useful or required by the Standard. (It
- -- ADR: also messes up the interpreter.)
+ -- ADR: commented out next new lines because I don't believe
+ -- ADR: the check is useful or required by the Standard. (It
+ -- ADR: also messes up the interpreter.)
tc_errs = [] -- map (map (fst . snd)) tc_dups
-- Ugh! Just keep the dup'd protonames
\begin{code}
doIfaceImports1
- :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module
- -> FAST_STRING -- name of module whose interface we're doing
- -> [IfaceImportDecl]
+ :: FAST_STRING -- name of module whose interface we're doing
+ -> [IfaceImportDecl ProtoName]
-> Rn12M ImportNameBags
-doIfaceImports1 _ _ [] = returnRn12 (emptyBag, emptyBag)
+doIfaceImports1 _ [] = returnRn12 (emptyBag, emptyBag)
-doIfaceImports1 mod_rn_fn int_mod_name (imp_decl1 : rest)
- = do_decl imp_decl1 `thenRn12` \ (vb1, tcb1) ->
- doIfaceImports1 mod_rn_fn int_mod_name rest `thenRn12` \ (vb2, tcb2) ->
--- pprTrace "vbags/tcbags:" (ppr PprDebug (vb1 `unionBags` vb2, [(s,p) | (s,(p,_)) <- bagToList (tcb1 `unionBags` tcb2)])) (
+doIfaceImports1 int_mod_name (imp_decl1 : rest)
+ = do_decl imp_decl1 `thenRn12` \ (vb1, tcb1) ->
+ doIfaceImports1 int_mod_name rest `thenRn12` \ (vb2, tcb2) ->
returnRn12 (vb1 `unionBags` vb2, tcb1 `unionBags` tcb2)
--- )
where
- do_decl (IfaceImportDecl orig_mod_name imports renamings src_loc)
+ do_decl (IfaceImportDecl orig_mod_name imports src_loc)
= -- Look at the renamings to get a suitable renaming function
- doRenamings mod_rn_fn int_mod_name orig_mod_name renamings
+ doRenamings{-not really-} int_mod_name orig_mod_name
`thenRn12` \ (orig_to_pn, local_to_pn) ->
-- Now deal with one import at a time, combining results.
returning a bag which maps local names to original names.
\begin{code}
-doIfaceImport1 :: ( FAST_STRING -- Original local name
+doIfaceImport1 :: ( ProtoName -- Original local name
-> (FAST_STRING, -- Local name in this interface
ProtoName) -- Its full protoname
- )
-
+ )
+
-> IntNameFun -- Local name to ProtoName; use for
-- constructors and class ops
-
+
-> ImportNameBags -- Accumulator
- -> IE -- An item in the import list
+ -> (IE ProtoName) -- An item in the import list
-> ImportNameBags
doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) (IEVar orig_name)
= int_import1_help orig_to_pn local_to_pn acc orig_name
-- the next ones will go away with 1.3:
+{- OLD:
doIfaceImport1 orig_to_pn local_to_pn acc (IEConWithCons orig_name _)
= int_import1_help orig_to_pn local_to_pn acc orig_name
doIfaceImport1 orig_to_pn local_to_pn acc (IEClsWithOps orig_name _)
= int_import1_help orig_to_pn local_to_pn acc orig_name
+-}
doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) other
- = panic "Rename1: strange import decl"
+ = panic "RnPass1: strange import decl"
-- Little help guy...
It can produce errors, if there is a domain clash on the renamings.
\begin{code}
---pprTrace
---instance Outputable _PackedString where
--- ppr sty s = ppStr (_UNPK_ s)
-
-doRenamings :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module
- -> FAST_STRING -- Name of the module whose interface we're working on
+doRenamings :: FAST_STRING -- Name of the module whose interface we're working on
-> FAST_STRING -- Original-name module for these renamings
- -> [Renaming] -- Renamings
-> Rn12M
- ((FAST_STRING -- Original local name to...
+ ((ProtoName -- Original local name to...
-> (FAST_STRING, -- ... Local name in this interface
- ProtoName) -- ... Its full protoname
- ),
+ ProtoName) -- ... Its full protoname
+ ),
IntNameFun) -- Use for constructors, class ops
-doRenamings mod_rn_fn int_mod orig_mod []
+doRenamings int_mod orig_mod
= returnRn12 (
- \ s ->
- let
- result = (s, Imp orig_mod s [int_mod] (mod_rn_fn s))
- in
--- pprTrace "name1a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
- result
--- )
- ,
-
\ (Unk s) ->
let
- result = Imp orig_mod s [int_mod] (mod_rn_fn s)
+ result = (s, Imp orig_mod s [int_mod] s)
in
--- pprTrace "name2a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
result
--- )
- )
-
-doRenamings mod_rn_fn int_mod orig_mod renamings
- = let
- local_rn_fn = mkRenamingFun renamings
- in
- --pprTrace "local_rns:" (ppr PprDebug renamings) (
- returnRn12 (
- \ s ->
- let
- local_name = local_rn_fn s
- result
- = (local_name, Imp orig_mod s [int_mod] (mod_rn_fn local_name))
- in
--- pprTrace "name1:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
- result
--- )
,
\ (Unk s) ->
let
- result
- = Imp orig_mod s [int_mod] (mod_rn_fn (local_rn_fn s))
+ result = Imp orig_mod s [int_mod] s
in
--- pprTrace "name2:" (ppCat [ppr PprDebug s, ppr PprDebug result]) (
result
--- )
)
- --)
-\end{code}
-
-\begin{code}
-mkRenamingFun :: [Renaming] -> FAST_STRING -> FAST_STRING
-
-mkRenamingFun [] = \ s -> s
-mkRenamingFun renamings
- = let
- rn_fn = lookupFM (listToFM -- OLD: mkStringLookupFn
- [ (old, new) | MkRenaming old new <- renamings ]
- ) -- OLD: False {-not-sorted-}
- in
- \s -> case rn_fn s of
- Nothing -> s
- Just s' -> s'
\end{code}
-
%************************************************************************
%* *
\subsection{Type declarations}
= mapRn12 do_decl ty_decls `thenRn12` \ decls_maybe ->
returnRn12 (catMaybes decls_maybe)
where
- do_decl (TyData context tycon tyvars condecls derivs (DataPragmas hidden_cons specs) src_loc)
+ do_decl (TySynonym tycon tyvars monoty src_loc)
= let
full_thing = returnRn12 (Just ty_decl')
in
- -- GHC doesn't allow derivings in interfaces
- (if null derivs
- then returnRn12 ()
- else addErrRn12 (derivingInIfaceErr tycon derivs src_loc)
- ) `thenRn12` \ _ ->
+ case (sifun tycon) of
+ NotWanted -> returnRn12 Nothing
+ Wanted -> full_thing
+ WantedWith (IEThingAll _) -> full_thing
+ WantedWith weird_ie -> full_thing
+ where
+ (tycon_name,_) = full_tc_nf tycon
+ tc_nf = fst . full_tc_nf
+ monoty' = doIfaceMonoType1 tc_nf monoty
+ ty_decl' = TySynonym tycon_name tyvars monoty' src_loc
+
+ do_decl (TyData context tycon tyvars condecls derivs pragmas src_loc)
+ = do_data context tycon condecls derivs pragmas src_loc `thenRn12` \ done_data ->
+ case done_data of
+ Nothing -> returnRn12 Nothing
+ Just (context', tycon', condecls', derivs', pragmas') ->
+ returnRn12 (Just (TyData context' tycon' tyvars condecls' derivs' pragmas' src_loc))
+
+ do_decl (TyNew context tycon tyvars condecl derivs pragmas src_loc)
+ = do_data context tycon condecl derivs pragmas src_loc `thenRn12` \ done_data ->
+ case done_data of
+ Nothing -> returnRn12 Nothing
+ Just (context', tycon', condecl', derivs', pragmas') ->
+ returnRn12 (Just (TyNew context' tycon' tyvars condecl' derivs' pragmas' src_loc))
+
+ --------------------------------------------
+ do_data context tycon condecls derivs (DataPragmas hidden_cons specs) src_loc
+ = let
+ full_thing = Just (context', tycon_name, condecls', deriv', (pragmas' False))
+ abs_thing = Just (context', tycon_name, [], deriv', (pragmas' True))
+ in
case (sifun tycon) of
NotWanted -> returnRn12 Nothing
- Wanted -> full_thing
- WantedWith (IEThingAll _) -> full_thing
- WantedWith (IEThingAbs _) -> returnRn12 (Just abs_ty_decl')
- WantedWith ie@(IEConWithCons _ _) -> full_thing
+ Wanted -> returnRn12 full_thing
+ WantedWith (IEThingAll _) -> returnRn12 full_thing
+ WantedWith (IEThingAbs _) -> returnRn12 abs_thing
WantedWith really_weird_ie -> -- probably a typo in the pgm
addErrRn12 (weirdImportExportConstraintErr
tycon really_weird_ie src_loc) `thenRn12` \ _ ->
- full_thing
+ returnRn12 full_thing
where
- (tycon_name, constr_nf) = full_tc_nf tycon
- tc_nf = fst . full_tc_nf
+ (tycon_name, constrfield_nf) = full_tc_nf tycon
+ tc_nf = fst . full_tc_nf
- condecls' = map (do_condecl constr_nf tc_nf) condecls
- hidden_cons' = map (do_condecl constr_nf tc_nf) hidden_cons
+ condecls' = map (do_condecl constrfield_nf tc_nf) condecls
+ hidden_cons' = map (do_condecl constrfield_nf tc_nf) hidden_cons
pragmas' invent_hidden
= DataPragmas (if null hidden_cons && invent_hidden
- then condecls' -- if importing abstractly but condecls were
- -- exported we add them to the data pragma
+ then condecls' -- if importing abstractly but condecls were
+ -- exported we add them to the data pragma
else hidden_cons')
specs {- ToDo: do_specs -}
context' = doIfaceContext1 tc_nf context
- deriv' = map tc_nf derivs -- rename derived classes
+ deriv' = case derivs of
+ Nothing -> Nothing
+ Just ds -> panic "doIfaceTyDecls1:derivs" -- Just (map tc_nf ds)
+ -- rename derived classes
- ty_decl' = TyData context' tycon_name tyvars condecls' deriv' (pragmas' False) src_loc
- abs_ty_decl'= TyData context' tycon_name tyvars [] deriv' (pragmas' True) src_loc
+ --------------------------------------------
+ -- one name fun for the data constructor, another for the type:
- do_decl (TySynonym tycon tyvars monoty pragmas src_loc)
- = let
- full_thing = returnRn12 (Just ty_decl')
- in
- case (sifun tycon) of
- NotWanted -> returnRn12 Nothing
- Wanted -> full_thing
- WantedWith (IEThingAll _) -> full_thing
+ do_condecl cf_nf tc_nf (ConDecl name tys src_loc)
+ = ConDecl (cf_nf name) (map (do_bang tc_nf) tys) src_loc
- WantedWith weird_ie -> full_thing
- where
- (tycon_name,_) = full_tc_nf tycon
- tc_nf = fst . full_tc_nf
- monoty' = doIfaceMonoType1 tc_nf monoty
- ty_decl' = TySynonym tycon_name tyvars monoty' pragmas src_loc
+ do_condecl cf_nf tc_nf (ConOpDecl ty1 op ty2 src_loc)
+ = ConOpDecl (do_bang tc_nf ty1) (cf_nf op) (do_bang tc_nf ty2) src_loc
- -- one name fun for the data constructor, another for the type:
+ do_condecl cf_nf tc_nf (NewConDecl name ty src_loc)
+ = NewConDecl (cf_nf name) (doIfaceMonoType1 tc_nf ty) src_loc
+
+ do_condecl cf_nf tc_nf (RecConDecl con fields src_loc)
+ = RecConDecl (cf_nf con) (map do_field fields) src_loc
+ where
+ do_field (var, ty) = (cf_nf var, do_bang tc_nf ty)
- do_condecl c_nf tc_nf (ConDecl name tys src_loc)
- = ConDecl (c_nf name) (doIfaceMonoTypes1 tc_nf tys) src_loc
+ --------------------------------------------
+ do_bang tc_nf (Banged ty) = Banged (doIfaceMonoType1 tc_nf ty)
+ do_bang tc_nf (Unbanged ty) = Unbanged (doIfaceMonoType1 tc_nf ty)
\end{code}
%************************************************************************
= let
full_thing = returnRn12 (Just class_decl')
in
- case (sifun cname) of
+ case (sifun cname) of
NotWanted -> returnRn12 Nothing
Wanted -> full_thing
WantedWith (IEThingAll _) -> full_thing
---??? WantedWith (IEThingAbs _) -> returnRn12 (Just abs_class_decl')
- WantedWith (IEClsWithOps _ _) -> full_thing
-- ToDo: add checking of IEClassWithOps
WantedWith really_weird_ie -> -- probably a typo in the pgm
addErrRn12 (weirdImportExportConstraintErr
\begin{code}
doIfaceInstDecls1 :: SelectiveImporter
- -> IntNameFun
+ -> IntNameFun
-> [ProtoNameInstDecl]
-> [ProtoNameInstDecl]
doIfaceInstDecls1 si tc_nf inst_decls
= catMaybes (map do_decl inst_decls)
where
- do_decl (InstDecl context cname ty EmptyMonoBinds False modname imod uprags pragmas src_loc)
+ do_decl (InstDecl cname ty EmptyMonoBinds False modname uprags pragmas src_loc)
= case (si cname, tycon_reqd) of
(NotWanted, NotWanted) -> Nothing
_ -> Just inst_decl'
where
- context' = doIfaceContext1 tc_nf context
- ty' = doIfaceMonoType1 tc_nf ty
+ ty' = doIfacePolyType1 tc_nf ty
- inst_decl' = InstDecl context' (tc_nf cname) ty' EmptyMonoBinds False modname imod uprags pragmas src_loc
+ inst_decl' = InstDecl (tc_nf cname) ty' EmptyMonoBinds False modname uprags pragmas src_loc
- tycon_reqd
+ tycon_reqd = _trace "RnPass1.tycon_reqd" NotWanted
+{- LATER:
= case getNonPrelOuterTyCon ty of
Nothing -> NotWanted -- Type doesn't have a user-defined tycon
-- at its outermost level
Just tycon -> si tycon -- It does, so look up in the si-fun
+-}
\end{code}
%************************************************************************
\begin{code}
doIfacePolyType1 :: IntNameFun -> ProtoNamePolyType -> ProtoNamePolyType
-doIfacePolyType1 tc_nf (UnoverloadedTy ty)
- = UnoverloadedTy (doIfaceMonoType1 tc_nf ty)
+doIfacePolyType1 tc_nf (HsPreForAllTy ctxt ty)
+ = HsPreForAllTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
-doIfacePolyType1 tc_nf (OverloadedTy ctxt ty)
- = OverloadedTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
+doIfacePolyType1 tc_nf (HsForAllTy tvs ctxt ty)
+ = HsForAllTy tvs (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty)
\end{code}
\begin{code}
\begin{code}
-doIfaceMonoTypes1 :: IntNameFun -> [ProtoNameMonoType] -> [ProtoNameMonoType]
-doIfaceMonoTypes1 tc_nf tys = map (doIfaceMonoType1 tc_nf) tys
-\end{code}
-
-
-\begin{code}
doIfaceMonoType1 :: IntNameFun -> ProtoNameMonoType -> ProtoNameMonoType
-doIfaceMonoType1 tc_nf (MonoTyVar tyvar) = MonoTyVar tyvar
+doIfaceMonoType1 tc_nf tv@(MonoTyVar _) = tv
-doIfaceMonoType1 tc_nf (ListMonoTy ty)
- = ListMonoTy (doIfaceMonoType1 tc_nf ty)
+doIfaceMonoType1 tc_nf (MonoListTy ty)
+ = MonoListTy (doIfaceMonoType1 tc_nf ty)
-doIfaceMonoType1 tc_nf (FunMonoTy ty1 ty2)
- = FunMonoTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2)
+doIfaceMonoType1 tc_nf (MonoFunTy ty1 ty2)
+ = MonoFunTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2)
-doIfaceMonoType1 tc_nf (TupleMonoTy tys)
- = TupleMonoTy (map (doIfacePolyType1 tc_nf) tys)
+doIfaceMonoType1 tc_nf (MonoTupleTy tys)
+ = MonoTupleTy (map (doIfaceMonoType1 tc_nf) tys)
-doIfaceMonoType1 tc_nf (MonoTyCon name tys)
- = MonoTyCon (tc_nf name) (doIfaceMonoTypes1 tc_nf tys)
+doIfaceMonoType1 tc_nf (MonoTyApp name tys)
+ = MonoTyApp (tc_nf name) (map (doIfaceMonoType1 tc_nf) tys)
+\end{code}
-#ifdef DPH
-doIfaceMonoType1 tc_nf (MonoTyProc tys ty)
- = MonoTyProc (doIfaceMonoTypes1 tc_nf tys) (doIfaceMonoType1 tc_nf ty)
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
-doIfaceMonoType1 tc_nf (MonoTyPod ty)
- = MonoTyPod (doIfaceMonoType1 tc_nf ty)
-#endif {- Data Parallel Haskell -}
+\begin{code}
+duplicateImportsInInterfaceErr iface dups
+ = panic "duplicateImportsInInterfaceErr: NOT DONE YET?"
+
+weirdImportExportConstraintErr thing constraint locn
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "Illegal import/export constraint on `",
+ ppr sty thing,
+ ppStr "': ", ppr PprForUser constraint])
\end{code}
%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1996
%
-\section[Rename2]{Second renaming pass: boil down to non-duplicated info}
+\section[RnPass2]{Second renaming pass: boil down to non-duplicated info}
\begin{code}
#include "HsVersions.h"
-module Rename2 (
- rnModule2,
+module RnPass2 (
+ rnModule2
-- for completeness
- Module, Bag, ProtoNamePat(..), InPat,
- PprStyle, Pretty(..), PrettyRep, ProtoName
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
-import AbsSyn
-import Errors ( dupNamesErr, Error(..) )
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsTypes ( cmpMonoType, pprParendMonoType )
-import IdInfo ( DeforestInfo(..) )
-import Maybes ( Maybe(..) )
-import ProtoName
-import RenameMonad12
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
+import Ubiq{-uitous-}
+
+import HsSyn
+import HsCore
+import HsPragmas
+import RdrHsSyn
+import RnMonad12
+
+import Bag ( Bag )
+import IdInfo ( DeforestInfo(..), Demand{-instances-}, UpdateInfo{-instance-} )
+import Outputable ( Outputable(..){-instances-} )
+import PprStyle ( PprStyle(..) )
+import Pretty -- quite a bit of it
+import ProtoName ( cmpProtoName, eqProtoName, eqByLocalName,
+ elemProtoNames, elemByLocalNames,
+ ProtoName(..)
+ )
+import RnUtils ( dupNamesErr )
+import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instances-} )
+import Util ( isIn, equivClasses,
+ panic, panic#, pprTrace, assertPanic
+ )
\end{code}
This pass removes duplicate declarations. Duplicates can arise when
[WDP 93/8/16] [Improved, at least WDP 93/08/26]
\begin{code}
-rnModule2 :: ProtoNameModule -> Rn12M ProtoNameModule
+rnModule2 :: ProtoNameHsModule -> Rn12M ProtoNameHsModule
-rnModule2 (Module mod_name exports imports fixes
+rnModule2 (HsModule mod_name exports imports fixes
ty_decls absty_sigs class_decls inst_decls specinst_sigs
defaults binds int_sigs src_loc)
rm_sigs_for_here mod_name int_sigs
`thenRn12` \ non_here_int_sigs ->
- uniquefy mod_name cmpSig selSig non_here_int_sigs
+ uniquefy mod_name cmpSig selSig non_here_int_sigs
`thenRn12` \ int_sigs ->
returnRn12
- (Module mod_name
- exports -- export and import lists are passed along
- imports -- for checking in Rename3; no other reason
- fixes
- ty_decls
- absty_sigs
- class_decls
- inst_decls
- specinst_sigs
- defaults
- binds
- int_sigs
- src_loc)
+ (HsModule mod_name
+ exports -- export and import lists are passed along
+ imports -- for checking in RnPass3; no other reason
+ fixes
+ ty_decls
+ absty_sigs
+ class_decls
+ inst_decls
+ specinst_sigs
+ defaults
+ binds
+ int_sigs
+ src_loc)
where
top_level_binders = collectTopLevelBinders binds
%************************************************************************
%* *
-\subsection[FixityDecls-Rename2]{Functions for @FixityDecls@}
+\subsection[FixityDecls-RnPass2]{Functions for @FixityDecls@}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsection[TyDecls-Rename2]{Functions for @TyDecls@}
+\subsection[TyDecls-RnPass2]{Functions for @TyDecls@}
%* *
%************************************************************************
\begin{code}
cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_
-cmpTys (TyData _ n1 _ _ _ _ _) (TyData _ n2 _ _ _ _ _) = cmpProtoName n1 n2
-cmpTys (TyData _ n1 _ _ _ _ _) other = LT_
-cmpTys (TySynonym n1 _ _ _ _) (TySynonym n2 _ _ _ _) = cmpProtoName n1 n2
-cmpTys a b = GT_
+cmpTys (TyData _ n1 _ _ _ _ _) (TyData _ n2 _ _ _ _ _) = cmpProtoName n1 n2
+cmpTys (TyNew _ n1 _ _ _ _ _) (TyNew _ n2 _ _ _ _ _) = cmpProtoName n1 n2
+cmpTys (TySynonym n1 _ _ _) (TySynonym n2 _ _ _) = cmpProtoName n1 n2
+cmpTys a b
+ = let tag1 = tag a
+ tag2 = tag b
+ in
+ if tag1 _LT_ tag2 then LT_ else GT_
+ where
+ tag (TyData _ _ _ _ _ _ _) = (ILIT(1) :: FAST_INT)
+ tag (TyNew _ _ _ _ _ _ _) = ILIT(2)
+ tag (TySynonym _ _ _ _) = ILIT(3)
\end{code}
\begin{code}
(\ p -> TyData c name1 tvs cons1 ds p locn1)
chooser_TyData
-selTys ts1@(TySynonym name1 tvs expand1 pragmas1 locn1)
- ts2@(TySynonym name2 _ expand2 pragmas2 locn2)
+selTys td1@(TyNew c name1 tvs con1 ds pragmas1 locn1)
+ td2@(TyNew _ name2 _ con2 _ pragmas2 locn2)
+ = selByBetterName "algebraic newtype"
+ name1 pragmas1 locn1 td1
+ name2 pragmas2 locn2 td2
+ (\ p -> TyNew c name1 tvs con1 ds p locn1)
+ chooser_TyNew
+
+selTys ts1@(TySynonym name1 tvs expand1 locn1)
+ ts2@(TySynonym name2 _ expand2 locn2)
= selByBetterName "type synonym"
- name1 pragmas1 locn1 ts1
- name2 pragmas2 locn2 ts2
- (\ p -> TySynonym name1 tvs expand1 p locn1)
+ name1 bottom locn1 ts1
+ name2 bottom locn2 ts2
+ (\ p -> TySynonym name1 tvs expand1 locn1)
chooser_TySynonym
+ where
+ bottom = panic "RnPass2:selTys:TySynonym"
\end{code}
If only one is ``abstract'' (no condecls), we take the other.
similar thing using pragmatic info.
\begin{code}
+chooser_TyNew wout pragmas1 locn1 td1@(TyNew _ name1 _ con1 _ _ _)
+ pragmas2 locn2 td2@(TyNew _ name2 _ con2 _ _ _)
+ = panic "RnPass2:chooser_TyNew"
+
+
chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _)
pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _)
= let
= ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
| ty_maybes <- specs ]]
-
+
pp_the_list [p] = p
pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
expansions are really the same; otherwise, we use the pragmas.
\begin{code}
-chooser_TySynonym wout pragmas1 locn1 ts1@(TySynonym name1 _ expand1 _ _)
- pragmas2 locn2 ts2@(TySynonym name2 _ expand2 _ _)
+chooser_TySynonym wout _ locn1 ts1@(TySynonym name1 _ expand1 _)
+ _ locn2 ts2@(TySynonym name2 _ expand2 _)
= if not (eqMonoType expand1 expand2) then
report_dup "type synonym" name1 locn1 name2 locn2 ts1
else
- sub_chooser pragmas1 pragmas2
- where
- sub_chooser NoTypePragmas b = returnRn12 (wout b)
- sub_chooser a NoTypePragmas = returnRn12 (wout a)
- sub_chooser a _ = returnRn12 (wout a) -- same, just pick one
+ returnRn12 ts1 -- same, just pick one
\end{code}
%************************************************************************
%* *
-\subsection[DataTypeSigs-Rename2]{Functions for @DataTypeSigs@}
+\subsection[SpecDataSigs-RnPass2]{Functions for @SpecDataSigs@}
%* *
%************************************************************************
\begin{code}
-cmpTySigs :: ProtoNameDataTypeSig -> ProtoNameDataTypeSig -> TAG_
+cmpTySigs :: ProtoNameSpecDataSig -> ProtoNameSpecDataSig -> TAG_
-cmpTySigs (AbstractTypeSig n1 _) (AbstractTypeSig n2 _)
- = cmpProtoName n1 n2
cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
= case cmpProtoName n1 n2 of
EQ_ -> LT_ -- multiple SPECIALIZE data pragmas allowed
other -> other
-cmpTySigs (AbstractTypeSig n1 _) (SpecDataSig n2 _ _)
- = LT_
-cmpTySigs (SpecDataSig n1 _ _) (AbstractTypeSig n2 _)
- = GT_
-selTySigs :: ProtoNameDataTypeSig
- -> ProtoNameDataTypeSig
- -> Rn12M ProtoNameDataTypeSig
-
-selTySigs s1@(AbstractTypeSig n1 locn1) s2@(AbstractTypeSig n2 locn2)
- = selByBetterName "ABSTRACT user-pragma"
- n1 bottom locn1 s1
- n2 bottom locn2 s2
- bottom bottom
- where
- bottom = panic "Rename2:selTySigs:AbstractTypeSig"
+selTySigs :: ProtoNameSpecDataSig
+ -> ProtoNameSpecDataSig
+ -> Rn12M ProtoNameSpecDataSig
selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
- = selByBetterName "ABSTRACT user-pragma"
+ = selByBetterName "SPECIALIZE data user-pragma"
n1 bottom locn1 s1
n2 bottom locn2 s2
bottom bottom
where
- bottom = panic "Rename2:selTySigs:SpecDataSig"
+ bottom = panic "RnPass2:selTySigs:SpecDataSig"
\end{code}
%************************************************************************
%* *
-\subsection[ClassDecl-Rename2]{Functions for @ClassDecls@}
+\subsection[ClassDecl-RnPass2]{Functions for @ClassDecls@}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsection[InstDecls-Rename2]{Functions for @InstDecls@}
+\subsection[InstDecls-RnPass2]{Functions for @InstDecls@}
%* *
%************************************************************************
\begin{code}
cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
-cmpInst (InstDecl _ c1 ty1 _ _ _ _ _ _ _) (InstDecl _ c2 ty2 _ _ _ _ _ _ _)
+cmpInst (InstDecl c1 ty1 _ _ _ _ _ _) (InstDecl c2 ty2 _ _ _ _ _ _)
= case cmpProtoName c1 c2 of
EQ_ -> cmpInstanceTypes ty1 ty2
other -> other
selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
-> Rn12M ProtoNameInstDecl
-selInst i1@(InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 uprags pragmas1 locn1)
- i2@(InstDecl _ _ _ _ from_here2 orig_mod2 infor_mod2 _ pragmas2 locn2)
+selInst i1@(InstDecl c ty bs from_here1 orig_mod1 uprags pragmas1 locn1)
+ i2@(InstDecl _ _ _ from_here2 orig_mod2 _ pragmas2 locn2)
= let
have_orig_mod1 = not (_NULL_ orig_mod1)
have_orig_mod2 = not (_NULL_ orig_mod2)
trace ("selInst: `same' instances coming in from two modules! (ToDo: msg!)")
choose_no2 -- arbitrary
else
+ panic "RnPass2: need original modules for imported instances"
+
+{- LATER ???
-- now we *cheat*: so we can use the "informing module" stuff
-- in "selByBetterName", we *make up* some ProtoNames for
-- these instance decls
selByBetterName "instance"
n1 pragmas1 locn1 i1
n2 pragmas2 locn2 i2
- (\ p -> InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1
+ (\ p -> InstDecl c ty bs from_here1 orig_mod1 infor_mod1
[{-none-}] p locn1)
chooser_Inst
+-}
\end{code}
\begin{code}
%************************************************************************
%* *
-\subsection[SpecInstSigs-Rename2]{Functions for @AbstractTypeSigs@}
+\subsection[SpecInstSigs-RnPass2]{Functions for @AbstractTypeSigs@}
%* *
%************************************************************************
\begin{code}
cmpSpecInstSigs
- :: ProtoNameSpecialisedInstanceSig -> ProtoNameSpecialisedInstanceSig -> TAG_
-selSpecInstSigs :: ProtoNameSpecialisedInstanceSig
- -> ProtoNameSpecialisedInstanceSig
- -> Rn12M ProtoNameSpecialisedInstanceSig
+ :: ProtoNameSpecInstSig -> ProtoNameSpecInstSig -> TAG_
+
+selSpecInstSigs :: ProtoNameSpecInstSig
+ -> ProtoNameSpecInstSig
+ -> Rn12M ProtoNameSpecInstSig
cmpSpecInstSigs a b = LT_
-selSpecInstSigs a b = panic "Rename2:selSpecInstSigs"
+selSpecInstSigs a b = panic "RnPass2:selSpecInstSigs"
\end{code}
%************************************************************************
cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
--- avoid BUG (ToDo)
-cmpSig _ _ = case (panic "cmpSig (rename2)") of { s -> -- should never happen
- cmpSig s s }
+cmpSig _ _ = panic# "cmpSig (rename2)"
selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
sel_strict a@(ImpStrictness b1 i1 g1) (ImpStrictness b2 i2 g2)
= if b1 /= b2 || i1 /= i2
- then pRAGMA_ERROR "strictness pragmas" a
+ then pRAGMA_ERROR "strictness pragmas" a
else recoverQuietlyRn12 NoGenPragmas (
selGenPragmas g1 locn1 g2 locn2
) `thenRn12` \ wrkr_prags ->
EQ_ -> ASSERT(dicts1 == dicts2)
recoverQuietlyRn12 NoGenPragmas (
selGenPragmas prags1 loc1 prags2 loc2
- ) `thenRn12` \ new_prags ->
+ ) `thenRn12` \ new_prags ->
selSpecialisations rest_specs1 loc1 rest_specs2 loc2
`thenRn12` \ rest ->
returnRn12 ( (spec1, dicts1, new_prags) : rest )
-> [a] -- things to be compared
-> Rn12M a
- check_group_consistency sel [] = panic "Rename2: runs produced an empty list"
+ check_group_consistency sel [] = panic "RnPass2: runs produced an empty list"
check_group_consistency sel (thing:things) = foldrRn12 sel thing things
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[Rename-three]{Third of the renaming passes}
+\section[RnPass3]{Third of the renaming passes}
The business of this pass is to:
\begin{itemize}
\begin{code}
#include "HsVersions.h"
-module Rename3 (
+module RnPass3 (
rnModule3,
- initRn3, Rn3M(..), -- re-exported from monad
+ initRn3, Rn3M(..) -- re-exported from monad
-- for completeness
- Module, Bag, ProtoNamePat(..), InPat, Maybe, Name,
- ExportFlag, PprStyle, Pretty(..), PrettyRep, ProtoName,
- PreludeNameFun(..), PreludeNameFuns(..), SplitUniqSupply
) where
-import AbsSyn
-import Bag -- lots of stuff
-import Errors ( dupNamesErr, dupPreludeNameErr,
- badExportNameErr, badImportNameErr,
- Error(..)
+import Ubiq{-uitous-}
+
+import RnMonad3
+import HsSyn
+import RdrHsSyn
+
+import Bag ( emptyBag, listToBag, unionBags, unionManyBags,
+ unitBag, snocBag, elemBag, bagToList, Bag
)
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import FiniteMap
-import Maybes ( Maybe(..) )
+import ErrUtils
+import HsPragmas ( DataPragmas(..) )
import Name ( Name(..) )
-import NameTypes ( fromPrelude, FullName )
-import ProtoName
-import RenameAuxFuns ( mkGlobalNameFun,
- GlobalNameFuns(..), GlobalNameFun(..),
- PreludeNameFuns(..), PreludeNameFun(..)
+import NameTypes ( fromPrelude, FullName{-instances-} )
+import Pretty
+import ProtoName ( cmpByLocalName, ProtoName(..) )
+import RnUtils ( mkGlobalNameFun,
+ GlobalNameMappers(..), GlobalNameMapper(..),
+ PreludeNameMappers(..), PreludeNameMapper(..),
+ dupNamesErr
)
-import RenameMonad3
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
+import SrcLoc ( SrcLoc{-instance-} )
+import Util ( isIn, removeDups, cmpPString, panic )
\end{code}
*********************************************************
*********************************************************
\begin{code}
-rnModule3 :: PreludeNameFuns
- -> [FAST_STRING] -- list of imported module names
- -> ProtoNameModule
+rnModule3 :: PreludeNameMappers
+ -> Bag FAST_STRING -- list of imported module names
+ -> ProtoNameHsModule
-> Rn3M ( NameSpaceAssoc, NameSpaceAssoc,
- GlobalNameFun, GlobalNameFun,
+ GlobalNameMapper, GlobalNameMapper,
Bag Error )
rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names
- (Module mod_name exports imports _ ty_decls _ class_decls
+ (HsModule mod_name exports imports _ ty_decls _ class_decls
inst_decls _ _ binds sigs _)
= putInfoDownM3 {- ???pnfs -} mod_name exports (
tc_gnf = mkGlobalNameFun mod_name tc_pnf tc_alist
in
- verifyExports v_gnf tc_gnf (mod_name : imported_mod_names) exports
+ verifyExports v_gnf tc_gnf (imported_mod_names `snocBag` mod_name) exports
`thenRn3` \ export_errs ->
verifyImports v_gnf tc_gnf imports `thenRn3` \ import_errs ->
export_errs `unionBags` import_errs
))
where
- deal_with_dups :: String -> PreludeNameFun -> NameSpaceAssoc
+ deal_with_dups :: String -> PreludeNameMapper -> NameSpaceAssoc
-> (NameSpaceAssoc, Bag Error)
deal_with_dups kind_str pnf alist
= (goodies,
listToBag (map mk_dup_err dup_lists) `unionBags`
- listToBag (map mk_prel_dup_err prel_dups)
+ listToBag (map mk_prel_dup_err prel_dups)
)
where
goodies :: [(ProtoName,Name)] --NameSpaceAssoc
(goodies, prel_dups) = if fromPrelude mod_name then
(singles, []) -- Compiling the prelude, so ignore this check
- else
+ else
partition local_def_of_prelude_thing singles
local_def_of_prelude_thing (Unk s, _)
- = case pnf s of
+ = case pnf s of
Just _ -> False -- Eek! It's a prelude name
Nothing -> True -- It isn't; all is ok
local_def_of_prelude_thing other = True
combiner (cons1, tycons1) (cons2, tycons2)
= (cons1 `unionBags` cons2, tycons1 `unionBags` tycons2)
- do_decl (TyData context tycon tyvars condecls deriv pragmas src_loc)
+ do_decl (TyData context tycon tyvars condecls _ pragmas src_loc)
= newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
`thenRn3` \ (uniq, tycon_name) ->
let
doConDecls3 False{-not invisibles-} exp_flag condecls `thenRn3` \ data_cons ->
do_data_pragmas exp_flag pragmas `thenRn3` \ pragma_data_cons ->
returnRn3 (data_cons `unionBags` pragma_data_cons,
- unitBag (tycon, OtherTyCon uniq tycon_name (length tyvars)
- True -- indicates @data@ tycon
+ unitBag (tycon, TyConName uniq tycon_name (length tyvars)
+ True -- indicates data/newtype tycon
[ c | (_,c) <- bagToList data_cons ]))
-
- do_decl (TySynonym tycon tyvars monoty pragmas src_loc)
+ do_decl (TyNew context tycon tyvars condecl _ pragmas src_loc)
+ = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
+ `thenRn3` \ (uniq, tycon_name) ->
+ let
+ exp_flag = getExportFlag tycon_name
+ -- we want to force all data cons to have the very
+ -- same export flag as their type constructor
+ in
+ doConDecls3 False{-not invisibles-} exp_flag condecl `thenRn3` \ data_con ->
+ do_data_pragmas exp_flag pragmas `thenRn3` \ pragma_data_con ->
+ returnRn3 (data_con `unionBags` pragma_data_con,
+ unitBag (tycon, TyConName uniq tycon_name (length tyvars)
+ True -- indicates data/newtype tycon
+ [ c | (_,c) <- bagToList data_con ]))
+
+ do_decl (TySynonym tycon tyvars monoty src_loc)
= newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
`thenRn3` \ (uniq, tycon_name) ->
returnRn3 (emptyBag,
- unitBag (tycon, OtherTyCon uniq tycon_name (length tyvars) False bottom))
- -- False indicates @type@ tycon
+ unitBag (tycon, TyConName uniq tycon_name (length tyvars) False bottom))
+ -- Flase indicates type tycon
where
bottom = panic "do_decl: data cons on synonym?"
do_decl (ConDecl con tys src_loc)
= mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
- returnRn3 (unitBag (con, OtherTopId uniq con_name))
+ returnRn3 (unitBag (con, ValName uniq con_name))
+ do_decl (ConOpDecl ty1 op ty2 src_loc)
+ = mk_name op src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
+ returnRn3 (unitBag (op, ValName uniq con_name))
+ do_decl (NewConDecl con ty src_loc)
+ = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
+ returnRn3 (unitBag (con, ValName uniq con_name))
+ do_decl (RecConDecl con fields src_loc)
+ = _trace "doConDecls3:RecConDecl:nothing for fields\n" $
+ mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
+ returnRn3 (unitBag (con, ValName uniq con_name))
\end{code}
`thenRn3` \ (uniq, class_name) ->
fixRn3 ( \ ~(clas_ops,_) ->
let
- class_Name = OtherClass uniq class_name
+ class_Name = ClassName uniq class_name
[ o | (_,o) <- bagToList clas_ops ]
in
doClassOps3 class_Name 1 sigs `thenRn3` \ (_, ops) ->
doClassOps3 clas tag1 rest `thenRn3` \ (tagr, bagr) ->
returnRn3 (tagr, bag1 `unionBags` bagr)
where
+{- LATER: NB: OtherVal is a Name, not a ProtoName
+ do_op (ClassOpSig op@(OtherVal uniq name) ty pragma src_loc)
+ = -- A classop whose unique is pre-ordained, so the type checker
+ -- can look it up easily
+ let
+ op_name = ClassOpName uniq clas (snd (getOrigName name)) tag
+ in
+ returnRn3 (tag+1, unitBag (op, op_name))
+-}
+
do_op (ClassOpSig op ty pragma src_loc)
= newFullNameM3 op src_loc False{-not tyconish-} Nothing `thenRn3` \ (uniq, _) ->
let
in
returnRn3 (tag+1, unitBag (op, op_name))
where
- -- A rather yukky function to get the original name out of a class operation.
+ -- A rather yukky function to get the original name out of a
+ -- class operation. The "snd (getOrigName ...)" in the other
+ -- ClassOpSig case does the corresponding yukky thing.
get_str :: ProtoName -> FAST_STRING
get_str (Unk s) = s
+ get_str (Qunk _ s) = s
get_str (Imp _ d _ _) = d
\end{code}
do_sig (Sig v ty pragma src_loc)
= newFullNameM3 v src_loc False{-distinctly untycon-ish-} Nothing
`thenRn3` \ (uniq, v_fname) ->
- returnRn3 (unitBag (v, OtherTopId uniq v_fname))
+ returnRn3 (unitBag (v, ValName uniq v_fname))
\end{code}
*********************************************************
*********************************************************
\begin{code}
-doBinds3 :: ProtoNameBinds -> Rn3M BagAssoc
+doBinds3 :: ProtoNameHsBinds -> Rn3M BagAssoc
doBinds3 EmptyBinds = returnRn3 emptyBag
doPat3 locn (VarPatIn n) = doTopLevName locn n
doPat3 locn (ListPatIn pats) = doPats3 locn pats
doPat3 locn (TuplePatIn pats) = doPats3 locn pats
-doPat3 locn (NPlusKPatIn n _) = doTopLevName locn n
doPat3 locn (AsPatIn p_name pat)
= andRn3 unionBags (doTopLevName locn p_name) (doPat3 locn pat)
doPat3 locn (ConOpPatIn pat1 name pat2)
= andRn3 unionBags (doPat3 locn pat1) (doPat3 locn pat2)
-
-#ifdef DPH
-doPat3 locn (ProcessorPatIn pats pat)
- = andRn3 unionBags (doPats3 locn pats) (doPat3 locn pat)
-#endif {- Data Parallel Haskell -}
\end{code}
\begin{code}
doTopLevName locn pn
= newFullNameM3 pn locn False{-un-tycon-ish-} Nothing `thenRn3` \ (uniq, name) ->
- returnRn3 (unitBag (pn, OtherTopId uniq name))
+ returnRn3 (unitBag (pn, ValName uniq name))
\end{code}
Have to check that export/imports lists aren't too drug-crazed.
\begin{code}
-verifyExports :: GlobalNameFun -> GlobalNameFun
- -> [FAST_STRING] -- module names that might appear
- -- in an export list; includes the
- -- name of this module
- -> [IE] -- export list
+verifyExports :: GlobalNameMapper -> GlobalNameMapper
+ -> Bag FAST_STRING -- module names that might appear
+ -- in an export list; includes the
+ -- name of this module
+ -> Maybe [IE ProtoName] -- export list
-> Rn3M (Bag Error)
-verifyExports v_gnf tc_gnf imported_mod_names exports
+verifyExports _ _ _ Nothing{-no export list-} = returnRn3 emptyBag
+
+verifyExports v_gnf tc_gnf imported_mod_names export_list@(Just exports)
= mapRn3 verify exports `thenRn3` \ errs ->
- chk_exp_dups exports `thenRn3` \ dup_errs ->
+ chk_exp_dups export_list `thenRn3` \ dup_errs ->
returnRn3 (unionManyBags (errs ++ dup_errs))
where
- present nf str = nf (Unk str)
-
ok = returnRn3 emptyBag
naughty nm msg = returnRn3 (unitBag (badExportNameErr (_UNPK_ nm) msg))
undef_name nm = naughty nm "is not defined."
dup_name (nm:_)= naughty nm "occurs more than once."
+ undef_name :: FAST_STRING -> Rn3M (Bag Error)
+ dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
+
----------------
+ chk_exp_dups :: Maybe [IE ProtoName] -> Rn3M [Bag Error]
+
chk_exp_dups exports
= let
- export_strs = [ nm | (nm, _) <- fst (getRawIEStrings exports) ]
- (_, dup_lists) = removeDups _CMP_STRING_ export_strs
+ export_strs = [ nm | (nm, _) <- fst (getRawExportees exports) ]
+ (_, dup_lists) = removeDups cmpByLocalName{-????-} export_strs
in
- mapRn3 dup_name dup_lists
+ mapRn3 dup_name [map getOccurrenceName dl | dl <- dup_lists]
---------------- the more serious checking
+ verify :: IE ProtoName -> Rn3M (Bag Error)
+
verify (IEVar v)
- = case (present v_gnf v) of { Nothing -> undef_name v; _ -> ok }
+ = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
verify (IEModuleContents mod)
- = if not (mod `is_elem` imported_mod_names) then undef_name mod else ok
- where
- is_elem = isIn "verifyExports"
-
- verify (IEThingAbs tc)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
- Just nm -> case nm of
- PreludeTyCon _ _ _ False{-syn-}
- -> naughty tc "must be exported with a `(..)' -- it's a Prelude synonym."
- OtherTyCon _ _ _ False{-syn-} _
- -> naughty tc "must be exported with a `(..)' -- it's a synonym."
-
- PreludeClass _ _
- -> naughty tc "cannot be exported \"abstractly\" (it's a Prelude class)."
- OtherClass _ _ _
- -> naughty tc "cannot be exported \"abstractly\" (it's a class)."
+ = if not (mod `elemBag` imported_mod_names) then undef_name mod else ok
+
+ verify (IEThingAbs tc)
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
+ Just nm -> let
+ naughty_tc = naughty (getOccurrenceName tc)
+ in
+ case nm of
+ TyConName _ _ _ False{-syn-} _
+ -> naughty_tc "must be exported with a `(..)' -- it's a synonym."
+
+ ClassName _ _ _
+ -> naughty_tc "cannot be exported \"abstractly\" (it's a class)."
_ -> ok
verify (IEThingAll tc)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
- Just nm -> case nm of
- OtherTyCon _ _ _ True{-data-} [{-no cons-}]
- -> naughty tc "can't be exported with a `(..)' -- it was imported abstractly."
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
+ Just nm -> let
+ naughty_tc = naughty (getOccurrenceName tc)
+ in
+ case nm of
+ TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
+ -> naughty_tc "can't be exported with a `(..)' -- it was imported abstractly."
_ -> ok
+{- OLD:
verify (IEConWithCons tc cs)
- = case (present tc_gnf tc) of
+ = case (tc_gnf tc) of
Nothing -> undef_name tc
Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
-- ToDo: turgid checking which we don't care about (WDP 94/10)
verify (IEClsWithOps c ms)
- = case (present tc_gnf c) of
+ = case (tc_gnf c) of
Nothing -> undef_name c
Just _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
-- ToDo: turgid checking which we don't care about (WDP 94/10)
+-}
\end{code}
Note: we're not too particular about whether something mentioned in an
import list is in {\em that} interface... (ToDo? Probably not.)
\begin{code}
-verifyImports :: GlobalNameFun -> GlobalNameFun
+verifyImports :: GlobalNameMapper -> GlobalNameMapper
-> [ProtoNameImportedInterface]
-> Rn3M (Bag Error)
= mapRn3 chk_one (map collect imports) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
where
- -- collect: name/locn, import list, renamings list
+ -- collect: name/locn, import list
- collect (ImportAll iff renamings)
- = (iface iff, [], [], renamings)
- collect (ImportSome iff imp_list renamings)
- = (iface iff, imp_list, [], renamings)
- collect (ImportButHide iff hide_list renamings)
- = (iface iff, [], hide_list, renamings)
+ collect (ImportMod iff qual asmod details)
+ = (iface iff, imp_list, hide_list)
+ where
+ (imp_list, hide_list)
+ = case details of
+ Nothing -> ([], [])
+ Just (True{-hidden-}, ies) -> ([], ies)
+ Just (_ {-unhidden-}, ies) -> (ies, [])
------------
- iface (MkInterface name _ _ _ _ _ _ locn) = (name, locn)
+ iface (Interface name _ _ _ _ _ _ locn) = (name, locn)
------------
- chk_one :: ((FAST_STRING, SrcLoc), [IE], [IE], [Renaming])
+ chk_one :: ((FAST_STRING, SrcLoc), [IE ProtoName], [IE ProtoName])
-> Rn3M (Bag Error)
- chk_one ((mod_name, locn), import_list, hide_list, renamings)
+ chk_one ((mod_name, locn), import_list, hide_list)
= mapRn3 verify import_list `thenRn3` \ errs1 ->
chk_imp_dups import_list `thenRn3` \ dup_errs ->
-- ToDo: we could check the hiding list more carefully
chk_imp_dups hide_list `thenRn3` \ dup_errs2 ->
- mapRn3 chk_rn renamings `thenRn3` \ errs2 ->
- returnRn3 (unionManyBags (errs1 ++ dup_errs ++ dup_errs2 ++ errs2))
+ returnRn3 (unionManyBags (errs1 ++ dup_errs ++ dup_errs2))
where
- present nf str = nf (Unk (rename_it str))
-
- rename_it str
- = case [ too | (MkRenaming from too) <- renamings, str == from ] of
- [] -> str
- (x:_) -> x
-
ok = returnRn3 emptyBag
naughty nm msg = returnRn3 (unitBag (badImportNameErr (_UNPK_ mod_name) (_UNPK_ nm) msg locn))
undef_name nm = naughty nm "is not defined."
- undef_rn_name n r = naughty n ("is not defined (renamed to `"++ _UNPK_ r ++"').")
dup_name (nm:_) = naughty nm "occurs more than once."
+ undef_name :: FAST_STRING -> Rn3M (Bag Error)
+ dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
+
----------------
chk_imp_dups imports
= let
- import_strs = [ nm | (nm, _) <- fst (getRawIEStrings imports) ]
+ import_strs = getRawImportees imports
(_, dup_lists) = removeDups _CMP_STRING_ import_strs
in
mapRn3 dup_name dup_lists
----------------
- chk_rn (MkRenaming from too) -- Note: "present" will rename
- = case (present v_gnf from) of -- the "from" to the "too"...
- Just _ -> ok
- Nothing -> case (present tc_gnf from) of
- Just _ -> ok
- Nothing -> undef_rn_name from too
+ verify :: IE ProtoName -> Rn3M (Bag Error)
- ----------------
verify (IEVar v)
- = case (present v_gnf v) of { Nothing -> undef_name v; _ -> ok }
-
- verify (IEThingAbs tc)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
- Just nm -> case nm of
- PreludeTyCon _ _ _ False{-syn-}
- -> naughty tc "must be imported with a `(..)' -- it's a Prelude synonym."
- OtherTyCon _ _ _ False{-syn-} _
- -> naughty tc "must be imported with a `(..)' -- it's a synonym."
- PreludeClass _ _
- -> naughty tc "cannot be imported \"abstractly\" (it's a Prelude class)."
- OtherClass _ _ _
- -> naughty tc "cannot be imported \"abstractly\" (it's a class)."
+ = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
+
+ verify (IEThingAbs tc)
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
+ Just nm -> let
+ naughty_tc = naughty (getOccurrenceName tc)
+ in
+ case nm of
+ TyConName _ _ _ False{-syn-} _
+ -> naughty_tc "must be imported with a `(..)' -- it's a synonym."
+ ClassName _ _ _
+ -> naughty_tc "cannot be imported \"abstractly\" (it's a class)."
_ -> ok
verify (IEThingAll tc)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
- Just nm -> case nm of
- OtherTyCon _ _ _ True{-data-} [{-no cons-}]
- -> naughty tc "can't be imported with a `(..)' -- the interface says it's abstract."
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
+ Just nm -> let
+ naughty_tc = naughty (getOccurrenceName tc)
+ in
+ case nm of
+ TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
+ -> naughty_tc "can't be imported with a `(..)' -- the interface says it's abstract."
_ -> ok
+{- OLD:
verify (IEConWithCons tc cs)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
-- One could add a great wad of tedious checking
-- here, but I am too lazy to do so. WDP 94/10
verify (IEClsWithOps c ms)
- = case (present tc_gnf c) of
- Nothing -> undef_name c
+ = case (tc_gnf c) of
+ Nothing -> undef_name (getOccurrenceName c)
Just _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
-- Ditto about tedious checking. WDP 94/10
+-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
+
+\begin{code}
+badExportNameErr name whats_wrong
+ = dontAddErrLoc
+ "Error in the export list" ( \ sty ->
+ ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
+
+------------------------------------------
+badImportNameErr mod name whats_wrong locn
+ = addErrLoc locn
+ ("Error in an import list for the module `"++mod++"'") ( \ sty ->
+ ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
+
+----------------------------
+-- dupNamesErr: from RnUtils
+
+--------------------------------------
+dupPreludeNameErr descriptor (nm, locn)
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ ppStr "A conflict with a Prelude ", ppStr descriptor,
+ ppStr ": ", ppr sty nm ])
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[Rename4]{Fourth of the renaming passes}
+\section[RnPass4]{Fourth of the renaming passes}
\begin{code}
#include "HsVersions.h"
-module Rename4 (
- rnModule4, rnPolyType4, rnGenPragmas4,
-
- initRn4, Rn4M(..), TyVarNamesEnv(..), -- re-exported from the monad
-
- -- for completeness
-
- Module, Bag, InPat, ProtoNamePat(..), RenamedPat(..),
- PolyType, Maybe, Name, ProtoName, GlobalNameFun(..),
- SrcLoc, SplitUniqSupply, Error(..), PprStyle,
- Pretty(..), PrettyRep
- ) where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty
-
-import AbsSyn
-import AbsUniType ( derivableClassKeys )
-import Errors
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import ProtoName ( eqProtoName, elemProtoNames )
-import RenameBinds4 ( rnTopBinds4, rnMethodBinds4 )
-import RenameMonad4
-import Util
+module RnPass4 ( rnModule, rnPolyType, rnGenPragmas ) where
+
+import Ubiq{-uitous-}
+import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+import HsPragmas -- all of it
+import HsCore -- all of it
+import RnMonad4
+
+import Class ( derivableClassKeys )
+import Maybes ( maybeToBool, catMaybes )
+import Name ( Name(..) )
+import Outputable ( Outputable(..), isAvarid )
+import Pretty ( ppHang, ppStr, ppCat, ppAboves )
+import ProtoName ( eqProtoName, elemProtoNames, ProtoName{-instance-} )
+import RnBinds4 ( rnTopBinds, rnMethodBinds )
+import SrcLoc ( SrcLoc{-instance-} )
+import Unique ( Unique{-instances-} )
+import UniqSet ( UniqSet(..) )
+import Util ( isIn, panic, assertPanic )
\end{code}
This pass `renames' the module+imported info, simultaneously
Checks that tyvars are used properly. This includes checking
for undefined tyvars, and tyvars in contexts that are ambiguous.
\item
-Checks that local variables are defined.
+Checks that local variables are defined.
\end{enumerate}
\begin{code}
-rnModule4 :: ProtoNameModule -> Rn4M RenamedModule
+rnModule :: ProtoNameHsModule -> Rn4M RenamedHsModule
-rnModule4 (Module mod_name exports _ fixes ty_decls absty_sigs
+rnModule (HsModule mod_name exports _ fixes ty_decls specdata_sigs
class_decls inst_decls specinst_sigs defaults
binds int_sigs src_loc)
= pushSrcLocRn4 src_loc (
- mapRn4 rnTyDecl4 ty_decls `thenRn4` \ new_ty_decls ->
-
- mapRn4 rnTySig4 absty_sigs `thenRn4` \ new_absty_sigs ->
-
- mapRn4 rnClassDecl4 class_decls `thenRn4` \ new_class_decls ->
-
- mapRn4 rnInstDecl4 inst_decls `thenRn4` \ new_inst_decls ->
-
- mapRn4 rnInstSpecSig4 specinst_sigs `thenRn4` \ new_specinst_sigs ->
-
- mapRn4 rnDefaultDecl4 defaults `thenRn4` \ new_defaults ->
-
- rnTopBinds4 binds `thenRn4` \ new_binds ->
-
- mapRn4 rnIntSig4 int_sigs `thenRn4` \ new_int_sigs ->
-
- rnFixes4 fixes `thenRn4` \ new_fixes ->
-
- returnRn4 (Module mod_name
- exports [{-imports finally clobbered-}] new_fixes
- new_ty_decls new_absty_sigs new_class_decls
+ mapRn4 rnTyDecl ty_decls `thenRn4` \ new_ty_decls ->
+ mapRn4 rnSpecDataSig specdata_sigs `thenRn4` \ new_specdata_sigs ->
+ mapRn4 rnClassDecl class_decls `thenRn4` \ new_class_decls ->
+ mapRn4 rnInstDecl inst_decls `thenRn4` \ new_inst_decls ->
+ mapRn4 rnSpecInstSig specinst_sigs `thenRn4` \ new_specinst_sigs ->
+ rnDefaultDecl defaults `thenRn4` \ new_defaults ->
+ rnTopBinds binds `thenRn4` \ new_binds ->
+ mapRn4 rnIntSig int_sigs `thenRn4` \ new_int_sigs ->
+ rnFixes fixes `thenRn4` \ new_fixes ->
+ rnExports exports `thenRn4` \ new_exports ->
+
+ returnRn4 (HsModule mod_name
+ new_exports [{-imports finally clobbered-}] new_fixes
+ new_ty_decls new_specdata_sigs new_class_decls
new_inst_decls new_specinst_sigs new_defaults
new_binds new_int_sigs src_loc)
)
-\end{code}
+rnExports Nothing = returnRn4 Nothing
+rnExports (Just exp_list)
+ = returnRn4 (Just (_trace "rnExports:trashing exports" []))
+\end{code}
%*********************************************************
%* *
%* *
%*********************************************************
-@rnTyDecl4@ uses the `global name function' to create a new type
+@rnTyDecl@ uses the `global name function' to create a new type
declaration in which local names have been replaced by their original
names, reporting any unknown names.
checks at the same time.
\begin{code}
-rnTyDecl4 :: ProtoNameTyDecl -> Rn4M RenamedTyDecl
+rnTyDecl :: ProtoNameTyDecl -> Rn4M RenamedTyDecl
-rnTyDecl4 (TyData context tycon tyvars condecls derivings pragmas src_loc)
+rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
= pushSrcLocRn4 src_loc (
lookupTyCon tycon `thenRn4` \ tycon' ->
mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
- rnContext4 tv_env context `thenRn4` \ context' ->
- rnConDecls4 tv_env False condecls `thenRn4` \ condecls' ->
- mapRn4 (rn_deriv tycon' src_loc) derivings `thenRn4` \ derivings' ->
+ rnContext tv_env context `thenRn4` \ context' ->
+ rnConDecls tv_env False condecls `thenRn4` \ condecls' ->
+ rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
recoverQuietlyRn4 (DataPragmas [] []) (
- rnDataPragmas4 tv_env pragmas
+ rnDataPragmas tv_env pragmas
) `thenRn4` \ pragmas' ->
returnRn4 (TyData context' tycon' tyvars' condecls' derivings' pragmas' src_loc)
)
- where
- rn_deriv tycon2 locn deriv
- = lookupClass deriv `thenRn4` \ clas_name ->
- case clas_name of
- PreludeClass key _ | key `is_elem` derivableClassKeys
- -> returnRn4 clas_name
- _ -> addErrRn4 (derivingNonStdClassErr tycon2 deriv locn) `thenRn4_`
- returnRn4 clas_name
- where
- is_elem = isIn "rn_deriv"
-rnTyDecl4 (TySynonym name tyvars ty pragmas src_loc)
+rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
+ = pushSrcLocRn4 src_loc (
+ lookupTyCon tycon `thenRn4` \ tycon' ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
+ rnContext tv_env context `thenRn4` \ context' ->
+ rnConDecls tv_env False condecl `thenRn4` \ condecl' ->
+ rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
+ recoverQuietlyRn4 (DataPragmas [] []) (
+ rnDataPragmas tv_env pragmas
+ ) `thenRn4` \ pragmas' ->
+ returnRn4 (TyNew context' tycon' tyvars' condecl' derivings' pragmas' src_loc)
+ )
+
+rnTyDecl (TySynonym name tyvars ty src_loc)
= pushSrcLocRn4 src_loc (
lookupTyCon name `thenRn4` \ name' ->
mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
- rnMonoType4 False{-no invisible types-} tv_env ty
+ rnMonoType False{-no invisible types-} tv_env ty
`thenRn4` \ ty' ->
- returnRn4 (TySynonym name' tyvars' ty' pragmas src_loc)
+ returnRn4 (TySynonym name' tyvars' ty' src_loc)
)
+
+rn_derivs tycon2 locn Nothing -- derivs not specified
+ = returnRn4 Nothing
+
+rn_derivs tycon2 locn (Just ds)
+ = mapRn4 (rn_deriv tycon2 locn) ds `thenRn4` \ derivs ->
+ returnRn4 (Just derivs)
+ where
+ rn_deriv tycon2 locn clas
+ = lookupClass clas `thenRn4` \ clas_name ->
+ case clas_name of
+ ClassName key _ _ | key `is_elem` derivableClassKeys
+ -> returnRn4 clas_name
+ _ -> addErrRn4 (derivingNonStdClassErr clas locn) `thenRn4_`
+ returnRn4 clas_name
+ where
+ is_elem = isIn "rn_deriv"
\end{code}
-@rnConDecls4@ uses the `global name function' to create a new
+@rnConDecls@ uses the `global name function' to create a new
constructor in which local names have been replaced by their original
names, reporting any unknown names.
\begin{code}
-rnConDecls4 :: TyVarNamesEnv
+rnConDecls :: TyVarNamesEnv
-> Bool -- True <=> allowed to see invisible data-cons
-> [ProtoNameConDecl]
-> Rn4M [RenamedConDecl]
-rnConDecls4 tv_env invisibles_allowed con_decls
+rnConDecls tv_env invisibles_allowed con_decls
= mapRn4 rn_decl con_decls
where
lookup_fn
rn_decl (ConDecl name tys src_loc)
= pushSrcLocRn4 src_loc (
- lookup_fn name `thenRn4` \ new_name ->
- mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys
- `thenRn4` \ new_tys ->
-
+ lookup_fn name `thenRn4` \ new_name ->
+ mapRn4 rn_bang_ty tys `thenRn4` \ new_tys ->
returnRn4 (ConDecl new_name new_tys src_loc)
)
+
+ rn_decl (ConOpDecl ty1 op ty2 src_loc)
+ = pushSrcLocRn4 src_loc (
+ lookup_fn op `thenRn4` \ new_op ->
+ rn_bang_ty ty1 `thenRn4` \ new_ty1 ->
+ rn_bang_ty ty2 `thenRn4` \ new_ty2 ->
+ returnRn4 (ConOpDecl new_ty1 new_op new_ty2 src_loc)
+ )
+
+ rn_decl (NewConDecl name ty src_loc)
+ = pushSrcLocRn4 src_loc (
+ lookup_fn name `thenRn4` \ new_name ->
+ rn_mono_ty ty `thenRn4` \ new_ty ->
+ returnRn4 (NewConDecl new_name new_ty src_loc)
+ )
+
+ rn_decl (RecConDecl con fields src_loc)
+ = panic "rnConDecls:RecConDecl"
+
+ ----------
+ rn_mono_ty = rnMonoType invisibles_allowed tv_env
+
+ rn_bang_ty (Banged ty)
+ = rn_mono_ty ty `thenRn4` \ new_ty ->
+ returnRn4 (Banged new_ty)
+ rn_bang_ty (Unbanged ty)
+ = rn_mono_ty ty `thenRn4` \ new_ty ->
+ returnRn4 (Unbanged new_ty)
\end{code}
%*********************************************************
%* *
-\subsection{ABSTRACT type-synonym pragmas}
+\subsection{SPECIALIZE data pragmas}
%* *
%*********************************************************
\begin{code}
-rnTySig4 :: ProtoNameDataTypeSig
- -> Rn4M RenamedDataTypeSig
-
-rnTySig4 (AbstractTypeSig tycon src_loc)
- = pushSrcLocRn4 src_loc (
- lookupTyCon tycon `thenRn4` \ tycon' ->
- returnRn4 (AbstractTypeSig tycon' src_loc)
- )
+rnSpecDataSig :: ProtoNameSpecDataSig
+ -> Rn4M RenamedSpecDataSig
-rnTySig4 (SpecDataSig tycon ty src_loc)
+rnSpecDataSig (SpecDataSig tycon ty src_loc)
= pushSrcLocRn4 src_loc (
let
tyvars = extractMonoTyNames eqProtoName ty
in
mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
lookupTyCon tycon `thenRn4` \ tycon' ->
- rnMonoType4 False tv_env ty `thenRn4` \ ty' ->
+ rnMonoType False tv_env ty `thenRn4` \ ty' ->
returnRn4 (SpecDataSig tycon' ty' src_loc)
)
\end{code}
%* *
%*********************************************************
-@rnClassDecl4@ uses the `global name function' to create a new
+@rnClassDecl@ uses the `global name function' to create a new
class declaration in which local names have been replaced by their
original names, reporting any unknown names.
\begin{code}
-rnClassDecl4 :: ProtoNameClassDecl -> Rn4M RenamedClassDecl
+rnClassDecl :: ProtoNameClassDecl -> Rn4M RenamedClassDecl
-rnClassDecl4 (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
+rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
= pushSrcLocRn4 src_loc (
mkTyVarNamesEnv src_loc [tyvar] `thenRn4` \ (tv_env, [tyvar']) ->
- rnContext4 tv_env context `thenRn4` \ context' ->
+ rnContext tv_env context `thenRn4` \ context' ->
lookupClass cname `thenRn4` \ cname' ->
mapRn4 (rn_op cname' tv_env) sigs `thenRn4` \ sigs' ->
- rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' ->
+ rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
recoverQuietlyRn4 NoClassPragmas (
- rnClassPragmas4 pragmas
+ rnClassPragmas pragmas
) `thenRn4` \ pragmas' ->
returnRn4 (ClassDecl context' cname' tyvar' sigs' mbinds' pragmas' src_loc)
)
where
rn_op clas tv_env (ClassOpSig op ty pragma locn)
= pushSrcLocRn4 locn (
- lookupClassOp clas op `thenRn4` \ op_name ->
- rnPolyType4 False True tv_env ty `thenRn4` \ new_ty ->
+ lookupClassOp clas op `thenRn4` \ op_name ->
+ rnPolyType False tv_env ty `thenRn4` \ 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_`
+-}
recoverQuietlyRn4 NoClassOpPragmas (
- rnClassOpPragmas4 pragma
- ) `thenRn4` \ new_pragma ->
+ rnClassOpPragmas pragma
+ ) `thenRn4` \ new_pragma ->
returnRn4 (ClassOpSig op_name new_ty new_pragma locn)
)
\end{code}
%*********************************************************
-@rnInstDecl4@ uses the `global name function' to create a new of
+@rnInstDecl@ uses the `global name function' to create a new of
instance declaration in which local names have been replaced by their
original names, reporting any unknown names.
\begin{code}
-rnInstDecl4 :: ProtoNameInstDecl -> Rn4M RenamedInstDecl
+rnInstDecl :: ProtoNameInstDecl -> Rn4M RenamedInstDecl
-rnInstDecl4 (InstDecl context cname ty mbinds from_here modname imod uprags pragmas src_loc)
+rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
= pushSrcLocRn4 src_loc (
- let tyvars = extractMonoTyNames eqProtoName ty in
+ let
+ tyvars = extract_poly_ty_names ty
+ in
mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
- rnContext4 tv_env context `thenRn4` \ context' ->
lookupClass cname `thenRn4` \ cname' ->
- rnMonoType4 False{-no invisibles-} tv_env ty
+ rnPolyType False{-no invisibles-} tv_env ty
`thenRn4` \ ty' ->
- rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' ->
+ rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
mapRn4 (rn_uprag cname') uprags `thenRn4` \ new_uprags ->
recoverQuietlyRn4 NoInstancePragmas (
- rnInstancePragmas4 cname' tv_env pragmas
+ rnInstancePragmas cname' tv_env pragmas
) `thenRn4` \ new_pragmas ->
- returnRn4 (InstDecl context' cname' ty' mbinds'
- from_here modname imod new_uprags new_pragmas src_loc)
+ returnRn4 (InstDecl cname' ty' mbinds'
+ from_here modname new_uprags new_pragmas src_loc)
)
where
rn_uprag class_name (SpecSig op ty using locn)
= ASSERT(not (maybeToBool using)) -- ToDo: SPEC method with explicit spec_id
pushSrcLocRn4 src_loc (
- lookupClassOp class_name op `thenRn4` \ op_name ->
- rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
+ lookupClassOp class_name op `thenRn4` \ op_name ->
+ rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
returnRn4 (SpecSig op_name new_ty Nothing locn)
)
- rn_uprag class_name (InlineSig op guide locn)
+ rn_uprag class_name (InlineSig op locn)
= pushSrcLocRn4 locn (
lookupClassOp class_name op `thenRn4` \ op_name ->
- returnRn4 (InlineSig op_name guide locn)
+ returnRn4 (InlineSig op_name locn)
)
rn_uprag class_name (DeforestSig op locn)
= pushSrcLocRn4 locn (
%*********************************************************
\begin{code}
-rnInstSpecSig4 :: ProtoNameSpecialisedInstanceSig
- -> Rn4M RenamedSpecialisedInstanceSig
+rnSpecInstSig :: ProtoNameSpecInstSig
+ -> Rn4M RenamedSpecInstSig
-rnInstSpecSig4 (InstSpecSig clas ty src_loc)
+rnSpecInstSig (SpecInstSig clas ty src_loc)
= pushSrcLocRn4 src_loc (
let tyvars = extractMonoTyNames eqProtoName ty in
mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
lookupClass clas `thenRn4` \ new_clas ->
- rnMonoType4 False tv_env ty `thenRn4` \ new_ty ->
- returnRn4 (InstSpecSig new_clas new_ty src_loc)
+ rnMonoType False tv_env ty `thenRn4` \ new_ty ->
+ returnRn4 (SpecInstSig new_clas new_ty src_loc)
)
\end{code}
%* *
%*********************************************************
-@rnDefaultDecl4@ uses the `global name function' to create a new set
+@rnDefaultDecl@ uses the `global name function' to create a new set
of default declarations in which local names have been replaced by
their original names, reporting any unknown names.
\begin{code}
-rnDefaultDecl4 :: ProtoNameDefaultDecl -> Rn4M RenamedDefaultDecl
-
-rnDefaultDecl4 (DefaultDecl tys src_loc)
- = pushSrcLocRn4 src_loc (
- mapRn4 (rnMonoType4 False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
- returnRn4 (DefaultDecl tys' src_loc)
- )
+rnDefaultDecl :: [ProtoNameDefaultDecl] -> Rn4M [RenamedDefaultDecl]
+
+rnDefaultDecl [] = returnRn4 []
+rnDefaultDecl [DefaultDecl tys src_loc]
+ = pushSrcLocRn4 src_loc $
+ mapRn4 (rnMonoType False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
+ returnRn4 [DefaultDecl tys' src_loc]
+rnDefaultDecl defs@(d:ds)
+ = addErrRn4 (dupDefaultDeclErr defs) `thenRn4_`
+ rnDefaultDecl [d]
\end{code}
%*************************************************************************
%*************************************************************************
Non-interface type signatures (which may include user-pragmas) are
-handled with @Binds@.
+handled with @HsBinds@.
@ClassOpSigs@ are dealt with in class declarations.
\begin{code}
-rnIntSig4 :: ProtoNameSig -> Rn4M RenamedSig
+rnIntSig :: ProtoNameSig -> Rn4M RenamedSig
-rnIntSig4 (Sig name ty pragma src_loc)
+rnIntSig (Sig name ty pragma src_loc)
= pushSrcLocRn4 src_loc (
lookupValue name `thenRn4` \ new_name ->
- rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
+ rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 pragma
+ rnGenPragmas pragma
) `thenRn4` \ new_pragma ->
returnRn4 (Sig new_name new_ty new_pragma src_loc)
)
%*************************************************************************
\begin{code}
-rnFixes4 :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl]
+rnFixes :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl]
-rnFixes4 fixities
+rnFixes fixities
= mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe ->
returnRn4 (catMaybes fixes_maybe)
where
%*********************************************************
\begin{code}
-rnPolyType4 :: Bool -- True <=> "invisible" tycons (in pragmas) allowed
- -> Bool -- True <=> snaffle tyvars from ty and
- -- stuff them in tyvar env; True for
- -- signatures and things; False for type
- -- synonym defns and things.
+rnPolyType :: Bool -- True <=> "invisible" tycons (in pragmas) allowed
-> TyVarNamesEnv
-> ProtoNamePolyType
-> Rn4M RenamedPolyType
-rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (UnoverloadedTy ty)
- = rn_poly_help invisibles_allowed snaffle_tyvars tv_env [] ty `thenRn4` \ (_, new_ty) ->
- returnRn4 (UnoverloadedTy new_ty)
+rnPolyType invisibles_allowed tv_env (HsForAllTy tvs ctxt ty)
+ = rn_poly_help invisibles_allowed tv_env tvs ctxt ty
-rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (OverloadedTy ctxt ty)
- = rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty `thenRn4` \ (new_ctxt, new_ty) ->
- returnRn4 (OverloadedTy new_ctxt new_ty)
+rnPolyType invisibles_allowed tv_env poly_ty@(HsPreForAllTy ctxt ty)
+ = rn_poly_help invisibles_allowed tv_env forall_tyvars ctxt ty
+ where
+ mentioned_tyvars = extract_poly_ty_names poly_ty
-rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (ForAllTy tvs ty)
- = getSrcLocRn4 `thenRn4` \ src_loc ->
- mkTyVarNamesEnv src_loc tvs `thenRn4` \ (tvenv2, new_tvs) ->
- let
- new_tvenv = catTyVarNamesEnvs tvenv2 tv_env
- in
- rnMonoType4 invisibles_allowed new_tvenv ty `thenRn4` \ new_ty ->
- returnRn4 (ForAllTy new_tvs new_ty)
+ forall_tyvars = mentioned_tyvars `minus_list` domTyVarNamesEnv tv_env
+
+ -- URGH! Why is this here? SLPJ
+ -- Because we are doing very delicate comparisons
+ -- (eqProtoName and all that); if we got rid of
+ -- that, then we could use ListSetOps stuff. WDP
+ minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
------------
-rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty
- = getSrcLocRn4 `thenRn4` \ src_loc ->
- let
- -- ToDo: this randomly-grabbing-tyvar names out
- -- of the type seems a little weird to me
- -- (WDP 94/11)
+extract_poly_ty_names (HsPreForAllTy ctxt ty)
+ = extractCtxtTyNames eqProtoName ctxt
+ `union_list`
+ extractMonoTyNames eqProtoName ty
+ where
+ -- see comment above
+ union_list [] [] = []
+ union_list [] b = b
+ union_list a [] = a
+ union_list (a:as) b
+ | a `elemProtoNames` b = union_list as b
+ | otherwise = a : union_list as b
- new_tyvars
- = extractMonoTyNames eqProtoName ty
- `minus_list` domTyVarNamesEnv tv_env
- in
- mkTyVarNamesEnv src_loc new_tyvars `thenRn4` \ (tv_env2, _) ->
+------------
+rn_poly_help :: Bool
+ -> TyVarNamesEnv
+ -> [ProtoName]
+ -> ProtoNameContext
+ -> ProtoNameMonoType
+ -> Rn4M RenamedPolyType
+
+rn_poly_help invisibles_allowed tv_env tyvars ctxt ty
+ = getSrcLocRn4 `thenRn4` \ src_loc ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) ->
let
- tv_env3 = if snaffle_tyvars
- then catTyVarNamesEnvs tv_env2 tv_env
- else tv_env -- leave it alone
+ tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
in
- rnContext4 tv_env3 ctxt `thenRn4` \ new_ctxt ->
- rnMonoType4 invisibles_allowed tv_env3 ty
- `thenRn4` \ new_ty ->
- returnRn4 (new_ctxt, new_ty)
- where
- minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
+ rnContext tv_env2 ctxt `thenRn4` \ new_ctxt ->
+ rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ new_ty ->
+ returnRn4 (HsForAllTy new_tyvars new_ctxt new_ty)
\end{code}
\begin{code}
-rnMonoType4 :: Bool -- allowed to look at invisible tycons
+rnMonoType :: Bool -- allowed to look at invisible tycons
-> TyVarNamesEnv
-> ProtoNameMonoType
-> Rn4M RenamedMonoType
-rnMonoType4 invisibles_allowed tv_env (MonoTyVar tyvar)
+rnMonoType invisibles_allowed tv_env (MonoTyVar tyvar)
= lookupTyVarName tv_env tyvar `thenRn4` \ tyvar' ->
returnRn4 (MonoTyVar tyvar')
-rnMonoType4 invisibles_allowed tv_env (ListMonoTy ty)
- = rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' ->
- returnRn4 (ListMonoTy ty')
+rnMonoType invisibles_allowed tv_env (MonoListTy ty)
+ = rnMonoType invisibles_allowed tv_env ty `thenRn4` \ ty' ->
+ returnRn4 (MonoListTy ty')
-rnMonoType4 invisibles_allowed tv_env (FunMonoTy ty1 ty2)
- = andRn4 FunMonoTy (rnMonoType4 invisibles_allowed tv_env ty1)
- (rnMonoType4 invisibles_allowed tv_env ty2)
+rnMonoType invisibles_allowed tv_env (MonoFunTy ty1 ty2)
+ = andRn4 MonoFunTy (rnMonoType invisibles_allowed tv_env ty1)
+ (rnMonoType invisibles_allowed tv_env ty2)
-rnMonoType4 invisibles_allowed tv_env (TupleMonoTy tys)
- = mapRn4 (rnPolyType4 invisibles_allowed False tv_env) tys `thenRn4` \ tys' ->
- returnRn4 (TupleMonoTy tys')
+rnMonoType invisibles_allowed tv_env (MonoTupleTy tys)
+ = mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
+ returnRn4 (MonoTupleTy tys')
-rnMonoType4 invisibles_allowed tv_env (MonoTyCon name tys)
+rnMonoType invisibles_allowed tv_env (MonoTyApp name tys)
= let
- lookup_fn = if invisibles_allowed
- then lookupTyConEvenIfInvisible
- else lookupTyCon
+ lookup_fn = if isAvarid (getOccurrenceName name)
+ then lookupTyVarName tv_env
+ else if invisibles_allowed
+ then lookupTyConEvenIfInvisible
+ else lookupTyCon
in
- lookup_fn name `thenRn4` \ tycon_name' ->
- mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
- returnRn4 (MonoTyCon tycon_name' tys')
+ lookup_fn name `thenRn4` \ name' ->
+ mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
+ returnRn4 (MonoTyApp name' tys')
-- for unfoldings only:
-rnMonoType4 invisibles_allowed tv_env (MonoTyVarTemplate name)
- = --pprTrace "rnMonoType4:MonoTyVarTemplate:" (ppAbove (ppr PprDebug name) (ppr PprDebug tv_env)) (
- lookupTyVarName tv_env name `thenRn4` \ new_name ->
- returnRn4 (MonoTyVarTemplate new_name)
- --)
+rnMonoType invisibles_allowed tv_env (MonoForAllTy tyvars_w_kinds ty)
+ = getSrcLocRn4 `thenRn4` \ src_loc ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) ->
+ let
+ tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
+ in
+ rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ ty' ->
+ returnRn4 (MonoForAllTy (new_tyvars `zip` kinds) ty')
+ where
+ (tyvars, kinds) = unzip tyvars_w_kinds
-rnMonoType4 invisibles_allowed tv_env (MonoDict clas ty)
+rnMonoType invisibles_allowed tv_env (MonoDictTy clas ty)
= lookupClass clas `thenRn4` \ new_clas ->
- rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ new_ty ->
- returnRn4 (MonoDict new_clas new_ty)
-
-#ifdef DPH
-rnMonoType4 invisibles_allowed tv_env (MonoTyProc tys ty)
- = mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
- rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' ->
- returnRn4 (MonoTyProc tys' ty')
-
-rnMonoType4 invisibles_allowed tv_env (MonoTyPod ty)
- = rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' ->
- returnRn4 (MonoTyPod ty')
-#endif {- Data Parallel Haskell -}
+ rnMonoType invisibles_allowed tv_env ty `thenRn4` \ new_ty ->
+ returnRn4 (MonoDictTy new_clas new_ty)
\end{code}
\begin{code}
-rnContext4 :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
+rnContext :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
-rnContext4 tv_env ctxt
+rnContext tv_env ctxt
= mapRn4 rn_ctxt ctxt
where
rn_ctxt (clas, tyvar)
%*********************************************************
\begin{code}
-rnDataPragmas4 tv_env (DataPragmas cons specs)
- = rnConDecls4 tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
+rnDataPragmas tv_env (DataPragmas cons specs)
+ = rnConDecls tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
mapRn4 types_n_spec specs `thenRn4` \ new_specs ->
returnRn4 (DataPragmas new_cons new_specs)
where
\end{code}
\begin{code}
-rnClassOpPragmas4 NoClassOpPragmas = returnRn4 NoClassOpPragmas
+rnClassOpPragmas NoClassOpPragmas = returnRn4 NoClassOpPragmas
-rnClassOpPragmas4 (ClassOpPragmas dsel defm)
- = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 dsel) `thenRn4` \ new_dsel ->
- recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 defm) `thenRn4` \ new_defm ->
+rnClassOpPragmas (ClassOpPragmas dsel defm)
+ = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas dsel) `thenRn4` \ new_dsel ->
+ recoverQuietlyRn4 NoGenPragmas (rnGenPragmas defm) `thenRn4` \ new_defm ->
returnRn4 (ClassOpPragmas new_dsel new_defm)
\end{code}
\begin{code}
-rnClassPragmas4 NoClassPragmas = returnRn4 NoClassPragmas
+rnClassPragmas NoClassPragmas = returnRn4 NoClassPragmas
-rnClassPragmas4 (SuperDictPragmas sds)
- = mapRn4 rnGenPragmas4 sds `thenRn4` \ new_sds ->
+rnClassPragmas (SuperDictPragmas sds)
+ = mapRn4 rnGenPragmas sds `thenRn4` \ new_sds ->
returnRn4 (SuperDictPragmas new_sds)
\end{code}
NB: In various cases around here, we don't @recoverQuietlyRn4@ around
-calls to @rnGenPragmas4@; not really worth it.
+calls to @rnGenPragmas@; not really worth it.
\begin{code}
-rnInstancePragmas4 _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
+rnInstancePragmas _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
-rnInstancePragmas4 _ _ (SimpleInstancePragma dfun)
- = rnGenPragmas4 dfun `thenRn4` \ new_dfun ->
+rnInstancePragmas _ _ (SimpleInstancePragma dfun)
+ = rnGenPragmas dfun `thenRn4` \ new_dfun ->
returnRn4 (SimpleInstancePragma new_dfun)
-rnInstancePragmas4 clas tv_env (ConstantInstancePragma dfun constms)
+rnInstancePragmas clas tv_env (ConstantInstancePragma dfun constms)
= recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 dfun
+ rnGenPragmas dfun
) `thenRn4` \ new_dfun ->
mapRn4 name_n_gen constms `thenRn4` \ new_constms ->
returnRn4 (ConstantInstancePragma new_dfun new_constms)
where
name_n_gen (op, gen)
= lookupClassOp clas op `thenRn4` \ new_op ->
- rnGenPragmas4 gen `thenRn4` \ new_gen ->
+ rnGenPragmas gen `thenRn4` \ new_gen ->
returnRn4 (new_op, new_gen)
-rnInstancePragmas4 clas tv_env (SpecialisedInstancePragma dfun specs)
+rnInstancePragmas clas tv_env (SpecialisedInstancePragma dfun specs)
= recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 dfun
+ rnGenPragmas dfun
) `thenRn4` \ new_dfun ->
mapRn4 types_n_spec specs `thenRn4` \ new_specs ->
returnRn4 (SpecialisedInstancePragma new_dfun new_specs)
where
types_n_spec (ty_maybes, dicts_to_ignore, inst)
= mapRn4 (rn_ty_maybe tv_env) ty_maybes `thenRn4` \ new_tys ->
- rnInstancePragmas4 clas tv_env inst `thenRn4` \ new_inst ->
+ rnInstancePragmas clas tv_env inst `thenRn4` \ new_inst ->
returnRn4 (new_tys, dicts_to_ignore, new_inst)
\end{code}
And some general pragma stuff: (Not sure what, if any, of this would
benefit from a TyVarNamesEnv passed in.... [ToDo])
\begin{code}
-rnGenPragmas4 NoGenPragmas = returnRn4 NoGenPragmas
+rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
-rnGenPragmas4 (GenPragmas arity upd def strict unfold specs)
+rnGenPragmas NoGenPragmas = returnRn4 NoGenPragmas
+
+rnGenPragmas (GenPragmas arity upd def strict unfold specs)
= recoverQuietlyRn4 NoImpUnfolding (
rn_unfolding unfold
) `thenRn4` \ new_unfold ->
rn_strictness (ImpStrictness is_bot ww_info wrkr_info)
= recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 wrkr_info
+ rnGenPragmas wrkr_info
) `thenRn4` \ new_wrkr_info ->
returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info)
types_n_gen (ty_maybes, dicts_to_ignore, gen)
= mapRn4 (rn_ty_maybe no_env) ty_maybes `thenRn4` \ new_tys ->
recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 gen
+ rnGenPragmas gen
) `thenRn4` \ new_gen ->
returnRn4 (new_tys, dicts_to_ignore, new_gen)
where
rn_ty_maybe tv_env Nothing = returnRn4 Nothing
rn_ty_maybe tv_env (Just ty)
- = rnMonoType4 True{-invisibles OK-} tv_env ty `thenRn4` \ new_ty ->
+ = rnMonoType True{-invisibles OK-} tv_env ty `thenRn4` \ new_ty ->
returnRn4 (Just new_ty)
------------
-rn_core tvenv (UfCoVar v)
+rn_core tvenv (UfVar v)
= rn_uf_id tvenv v `thenRn4` \ vname ->
- returnRn4 (UfCoVar vname)
+ returnRn4 (UfVar vname)
-rn_core tvenv (UfCoLit lit)
- = returnRn4 (UfCoLit lit)
+rn_core tvenv (UfLit lit)
+ = returnRn4 (UfLit lit)
-rn_core tvenv (UfCoCon con tys as)
+rn_core tvenv (UfCon con tys as)
= lookupValueEvenIfInvisible con `thenRn4` \ new_con ->
mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys ->
mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as ->
- returnRn4 (UfCoCon new_con new_tys new_as)
+ returnRn4 (UfCon new_con new_tys new_as)
-rn_core tvenv (UfCoPrim op tys as)
+rn_core tvenv (UfPrim op tys as)
= rn_core_primop tvenv op `thenRn4` \ new_op ->
mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys ->
mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as ->
- returnRn4 (UfCoPrim new_op new_tys new_as)
+ returnRn4 (UfPrim new_op new_tys new_as)
-rn_core tvenv (UfCoLam binders body)
- = mapRn4 (rn_binder tvenv) binders `thenRn4` \ new_binders ->
- let
- bs = [ b | (b, ty) <- new_binders ]
- in
- extendSS bs (rn_core tvenv body) `thenRn4` \ new_body ->
- returnRn4 (UfCoLam new_binders new_body)
+rn_core tvenv (UfLam binder body)
+ = rn_binder tvenv binder `thenRn4` \ (b,ty) ->
+ extendSS [b] (rn_core tvenv body) `thenRn4` \ new_body ->
+ returnRn4 (UfLam (b,ty) new_body)
-rn_core tvenv (UfCoTyLam tv body)
- = getSrcLocRn4 `thenRn4` \ src_loc ->
- mkTyVarNamesEnv src_loc [tv] `thenRn4` \ (tvenv2, [new_tv]) ->
- let
- new_tvenv = catTyVarNamesEnvs tvenv2 tvenv
- in
- rn_core new_tvenv body `thenRn4` \ new_body ->
- returnRn4 (UfCoTyLam new_tv new_body)
-
-rn_core tvenv (UfCoApp fun arg)
+rn_core tvenv (UfApp fun arg)
= rn_core tvenv fun `thenRn4` \ new_fun ->
rn_atom tvenv arg `thenRn4` \ new_arg ->
- returnRn4 (UfCoApp new_fun new_arg)
-
-rn_core tvenv (UfCoTyApp expr ty)
- = rn_core tvenv expr `thenRn4` \ new_expr ->
- rn_core_type tvenv ty `thenRn4` \ new_ty ->
- returnRn4 (UfCoTyApp new_expr new_ty)
+ returnRn4 (UfApp new_fun new_arg)
-rn_core tvenv (UfCoCase expr alts)
+rn_core tvenv (UfCase expr alts)
= rn_core tvenv expr `thenRn4` \ new_expr ->
rn_alts alts `thenRn4` \ new_alts ->
- returnRn4 (UfCoCase new_expr new_alts)
+ returnRn4 (UfCase new_expr new_alts)
where
rn_alts (UfCoAlgAlts alg_alts deflt)
= mapRn4 rn_alg_alt alg_alts `thenRn4` \ new_alts ->
- rn_deflt deflt `thenRn4` \ new_deflt ->
+ rn_deflt deflt `thenRn4` \ new_deflt ->
returnRn4 (UfCoAlgAlts new_alts new_deflt)
where
- rn_alg_alt (con, params, rhs)
+ rn_alg_alt (con, params, rhs)
= lookupValueEvenIfInvisible con `thenRn4` \ new_con ->
mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params ->
let
rn_alts (UfCoPrimAlts prim_alts deflt)
= mapRn4 rn_prim_alt prim_alts `thenRn4` \ new_alts ->
- rn_deflt deflt `thenRn4` \ new_deflt ->
+ rn_deflt deflt `thenRn4` \ new_deflt ->
returnRn4 (UfCoPrimAlts new_alts new_deflt)
where
- rn_prim_alt (lit, rhs)
+ rn_prim_alt (lit, rhs)
= rn_core tvenv rhs `thenRn4` \ new_rhs ->
returnRn4 (lit, new_rhs)
extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
returnRn4 (UfCoBindDefault new_b new_rhs)
-rn_core tvenv (UfCoLet bind body)
+rn_core tvenv (UfLet bind body)
= rn_bind bind `thenRn4` \ (new_bind, new_binders) ->
extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body ->
- returnRn4 (UfCoLet new_bind new_body)
+ returnRn4 (UfLet new_bind new_body)
where
rn_bind (UfCoNonRec b rhs)
= rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) ->
- rn_core tvenv rhs `thenRn4` \ new_rhs ->
+ rn_core tvenv rhs `thenRn4` \ new_rhs ->
returnRn4 (UfCoNonRec new_b new_rhs, [binder])
rn_bind (UfCoRec pairs)
rn_core tvenv rhs `thenRn4` \ new_rhs ->
returnRn4 ((new_b, new_ty), new_rhs)
-rn_core tvenv (UfCoSCC uf_cc body)
+rn_core tvenv (UfSCC uf_cc body)
= rn_cc uf_cc `thenRn4` \ new_cc ->
rn_core tvenv body `thenRn4` \ new_body ->
- returnRn4 (UfCoSCC new_cc new_body)
+ returnRn4 (UfSCC new_cc new_body)
where
rn_cc (UfAutoCC id m g is_dupd is_caf)
= rn_uf_id tvenv id `thenRn4` \ new_id ->
------------
rn_core_type tvenv ty
- = rnPolyType4 True{-invisible tycons OK-} False tvenv ty
+ = rnPolyType True{-invisible tycons OK-} tvenv ty
+\end{code}
+
+
+\begin{code}
+derivingNonStdClassErr clas locn sty
+ = ppHang (ppStr "Non-standard class in deriving")
+ 4 (ppCat [ppr sty clas, ppr sty locn])
+
+dupDefaultDeclErr defs sty
+ = ppHang (ppStr "Duplicate default declarations")
+ 4 (ppAboves (map pp_def_loc defs))
+ where
+ pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[Rename-aux-funs]{Functions used by both renaming passes}
+\section[RnUtils]{Functions used by both renaming passes}
\begin{code}
#include "HsVersions.h"
-module RenameAuxFuns (
+module RnUtils (
mkGlobalNameFun, mkNameFun,
- GlobalNameFun(..), GlobalNameFuns(..),
- PreludeNameFun(..), PreludeNameFuns(..),
+ GlobalNameMapper(..), GlobalNameMappers(..),
+ PreludeNameMapper(..), PreludeNameMappers(..),
- -- and for self-containedness...
- Bag, ProtoName, Maybe
+ dupNamesErr -- used in various places
) where
-IMPORT_Trace -- ToDo: rm (for debugging)
-import Outputable
-import Pretty
+import Ubiq{-uitous-}
-import Bag ( Bag, bagToList )
-import FiniteMap
-import Maybes
-import Name ( Name ) -- for instances
---OLD: import NameEnv
-import ProtoName
-import Util
+import Bag ( bagToList, Bag )
+import FiniteMap ( lookupFM, listToFM )
+import Name ( Name{-instances-} )
+import Outputable ( pprNonOp )
+import PprStyle ( PprStyle(..) )
+import Pretty
+import ProtoName ( ProtoName(..) )
+import Util ( cmpPString, removeDups, pprPanic, panic )
\end{code}
\begin{code}
-type GlobalNameFun = ProtoName -> Maybe Name
-type GlobalNameFuns = (GlobalNameFun, GlobalNameFun)
+type GlobalNameMapper = ProtoName -> Maybe Name
+type GlobalNameMappers = (GlobalNameMapper, GlobalNameMapper)
-type PreludeNameFun = FAST_STRING -> Maybe Name
-type PreludeNameFuns = (PreludeNameFun, -- Values
- PreludeNameFun -- Types and classes
+type PreludeNameMapper = FAST_STRING -> Maybe Name
+type PreludeNameMappers = (PreludeNameMapper, -- Values
+ PreludeNameMapper -- Types and classes
)
\end{code}
\begin{code}
mkGlobalNameFun :: FAST_STRING -- The module name
- -> PreludeNameFun -- The prelude things
- -> [(ProtoName, Name)] -- The local and imported things
- -> GlobalNameFun -- The global name function
+ -> PreludeNameMapper -- The prelude things
+ -> [(ProtoName, Name)] -- The local and imported things
+ -> GlobalNameMapper -- The global name function
mkGlobalNameFun this_module prel_nf alist
= the_fun
-- for a prelude thing.
--
-- Neither should they be in the domain of the imp_fun, because
- -- prelude things will have been converted to Prel x rather than
+ -- prelude things will have been converted to Prel x rather than
-- Imp p q r s.
--
-- So we strip out prelude things from the alist; this is not just
unk_fun = lookupFM (listToFM [(get_local pn,n) | (pn,n) <- non_prel_alist])
imp_fun = lookupFM (listToFM [(get_orig pn,n) | (pn,n) <- non_prel_alist])
-{- OLD:
- unk_fun = mkStringLookupFn [(get_local pn,n) | (pn,n) <- non_prel_alist] False{-not sorted-}
- imp_fun = mk2StringLookupFn [(get_orig pn,n) | (pn,n) <- non_prel_alist] False{-not sorted-}
--}
-- the lists *are* sorted by *some* ordering (by local
-- names), but not generally, and not in some way we
-- are going to rely on.
mkNameFun the_bag
= case (removeDups cmp (bagToList the_bag)) of { (no_dup_list, dups) ->
- case (lookupFM (listToFM no_dup_list)) of { the_fun ->
- --OLD :case (mkStringLookupFn no_dup_list True{-list is pre-sorted-}) of the_fun ->
- (the_fun, dups)
- }}
+ case (lookupFM (listToFM no_dup_list)) of { the_fun ->
+ (the_fun, dups) }}
where
cmp :: (FAST_STRING, a) -> (FAST_STRING, a) -> TAG_
cmp (s1,_) (s2,_) = _CMP_STRING_ s1 s2
\end{code}
+
+\begin{code}
+dupNamesErr descriptor ((first_pname,locn1) : dup_things) sty
+ = ppAboves (first_item : map dup_item dup_things)
+ where
+ first_item
+ = ppBesides [ ppr PprForUser locn1,
+ ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ",
+ pprNonOp sty first_pname ]
+
+ dup_item (pname, locn)
+ = ppBesides [ ppr PprForUser locn,
+ ppStr ": here was another declaration of `", pprNonOp sty pname, ppStr "'" ]
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface AnalFBWW where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-analFBWW :: (GlobalSwitch -> Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers}
module AnalFBWW ( analFBWW ) where
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import PlainCore
-import TaggedCore
import Util
import Id ( addIdFBTypeInfo )
-import IdInfo
-import IdEnv
-import AbsPrel ( foldrId, buildId,
- nilDataCon, consDataCon, mkListTy, mkFunTy,
- unpackCStringAppendId
- )
+import IdInfo
+import PrelInfo ( foldrId, buildId,
+ nilDataCon, consDataCon, mkListTy, mkFunTy,
+ unpackCStringAppendId
+ )
import BinderInfo
import SimplEnv -- everything
-import NewOccurAnal
+import OccurAnal -- OLD: was NewOccurAnal
import Maybes
\end{code}
\begin{code}
-analFBWW
- :: (GlobalSwitch -> Bool)
- -> PlainCoreProgram
- -> PlainCoreProgram
+analFBWW
+ :: (GlobalSwitch -> Bool)
+ -> [CoreBinding]
+ -> [CoreBinding]
analFBWW switch top_binds = trace "ANALFBWW" (snd anno)
where
anals :: [InBinding]
\end{code}
\begin{code}
-data OurFBType
+data OurFBType
= IsFB FBType
| IsNotFB -- unknown
| IsCons -- \ xy -> (:) ty xy
deriving (Eq)
-- We only handle *reasonable* types
-- Later might add concept of bottom
- -- because foldr f z (<bottom>) = <bottom>
+ -- because foldr f z (<bottom>) = <bottom>
unknownFBType = IsNotFB
goodProdFBType = IsFB (FBType [] FBGoodProd)
maybeFBtoFB (Nothing) = IsNotFB
addArgs :: Int -> OurFBType -> OurFBType
-addArgs n (IsFB (FBType args prod))
+addArgs n (IsFB (FBType args prod))
= IsFB (FBType (take n (repeat FBBadConsum) ++ args) prod)
addArgs n IsNotFB = IsNotFB
addArgs n IsCons = panic "adding argument to a cons"
--
-- [ build g ] is a good context
--
-analExprFBWW (CoApp (CoTyApp (CoVar bld) _) _) env
+analExprFBWW (App (CoTyApp (Var bld) _) _) env
| bld == buildId = goodProdFBType
--
-- [ foldr (:) ys xs ] ==> good
-- (but better if xs)
--
-analExprFBWW (CoApp (CoApp (CoApp
- (CoTyApp (CoTyApp (CoVar foldr_id) _) _) (CoVarAtom c)) _) _)
- env
+analExprFBWW (App (App (App
+ (CoTyApp (CoTyApp (Var foldr_id) _) _) (VarArg c)) _) _)
+ env
| pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c))
(ppr PprDebug foldr_id)
(foldr_id == foldrId && isCons c) = goodProdFBType
isCons c = case lookupIdEnv env c of
Just IsCons -> True
_ -> False
-analExprFBWW (CoVar v) env = maybeFBtoFB (lookupIdEnv env v)
-analExprFBWW (CoLit _) _ = unknownFBType
+analExprFBWW (Var v) env = maybeFBtoFB (lookupIdEnv env v)
+analExprFBWW (Lit _) _ = unknownFBType
--
-- [ x : xs ] ==> good iff [ xs ] is good
--
-analExprFBWW (CoCon con _ [_,CoVarAtom y]) env
+analExprFBWW (Con con _ [_,VarArg y]) env
| con == consDataCon = maybeFBtoFB (lookupIdEnv env y)
--
-- [] is good
--
-analExprFBWW (CoCon con _ []) _
+analExprFBWW (Con con _ []) _
| con == nilDataCon = goodProdFBType
-analExprFBWW (CoCon _ _ _) _ = unknownFBType
-analExprFBWW (CoPrim _ _ _) _ = unknownFBType
+analExprFBWW (Con _ _ _) _ = unknownFBType
+analExprFBWW (Prim _ _ _) _ = unknownFBType
-- \ xy -> (:) ty xy == a CONS
-analExprFBWW (CoLam [(x,_),(y,_)]
- (CoCon con _ [CoVarAtom x',CoVarAtom y'])) env
- | con == consDataCon && x == x' && y == y'
- = IsCons
-analExprFBWW (CoLam ids e) env
- = addArgs (length ids) (analExprFBWW e (delManyFromIdEnv env (map fst ids)))
+
+analExprFBWW (Lam (x,_) (Lam (y,_)
+ (Con con _ [VarArg x',VarArg y']))) env
+ | con == consDataCon && x == x' && y == y'
+ = IsCons
+analExprFBWW (Lam (id,_) e) env
+ = addArgs 1 (analExprFBWW e (delOneFromIdEnv env id))
+
analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
-analExprFBWW (CoApp f atom) env = rmArg (analExprFBWW f env)
+analExprFBWW (App f atom) env = rmArg (analExprFBWW f env)
analExprFBWW (CoTyApp f ty) env = analExprFBWW f env
-analExprFBWW (CoSCC lab e) env = analExprFBWW e env
-analExprFBWW (CoLet binds e) env = analExprFBWW e (analBind binds env)
-analExprFBWW (CoCase e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
+analExprFBWW (SCC lab e) env = analExprFBWW e env
+analExprFBWW (Let binds e) env = analExprFBWW e (analBind binds env)
+analExprFBWW (Case e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
-analAltsFBWW (CoAlgAlts alts deflt) env =
+analAltsFBWW (AlgAlts alts deflt) env =
case analDefFBWW deflt env of
Just ty -> ty : tys
Nothing -> tys
where
tys = map (\(con,binders,e) -> analExprFBWW e (delManyFromIdEnv env (map fst binders))) alts
-analAltsFBWW (CoPrimAlts alts deflt) env =
+analAltsFBWW (PrimAlts alts deflt) env =
case analDefFBWW deflt env of
Just ty -> ty : tys
Nothing -> tys
tys = map (\(lit,e) -> analExprFBWW e env) alts
-analDefFBWW CoNoDefault env = Nothing
-analDefFBWW (CoBindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
+analDefFBWW NoDefault env = Nothing
+analDefFBWW (BindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v)))
\end{code}
\begin{code}
analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType
-analBindExpr bnd expr env =
+analBindExpr bnd expr env =
case analExprFBWW expr env of
- IsFB ty@(FBType [] _) ->
+ IsFB ty@(FBType [] _) ->
if oneSafeOcc False bnd
then IsFB ty
else IsNotFB
other -> other
analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType
-analBind (CoNonRec (v,bnd) e) env =
+analBind (NonRec (v,bnd) e) env =
case analBindExpr bnd e env of
ty@(IsFB _) -> addOneToIdEnv env v ty
ty@(IsCons) -> addOneToIdEnv env v ty
_ -> delOneFromIdEnv env v -- remember about shadowing!
-analBind (CoRec binds) env =
+analBind (Rec binds) env =
let
first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds,
- (_,args,_) <- [digForLambdas e]]
+ (_,_,args,_) <- [digForLambdas e]]
env' = delManyFromIdEnv env (map (fst.fst) binds)
in
growIdEnvList env' (fixpoint 0 binds env' first_set)
fixpoint :: Int -> [(InBinder,InExpr)] -> IdEnv OurFBType -> [(Id,OurFBType)] -> [(Id,OurFBType)]
-fixpoint n binds env maps =
- if maps == maps'
+fixpoint n binds env maps =
+ if maps == maps'
then maps
else fixpoint (n+1) binds env maps'
where
\begin{code}
-annotateExprFBWW :: InExpr -> IdEnv OurFBType -> PlainCoreExpr
-annotateExprFBWW (CoVar v) env = CoVar v
-annotateExprFBWW (CoLit i) env = CoLit i
-annotateExprFBWW (CoCon c t a) env = CoCon c t a
-annotateExprFBWW (CoPrim p t a) env = CoPrim p t a
-annotateExprFBWW (CoLam ids e) env = CoLam ids' (annotateExprFBWW e (delManyFromIdEnv env ids'))
- where ids' = map fst ids
+annotateExprFBWW :: InExpr -> IdEnv OurFBType -> CoreExpr
+annotateExprFBWW (Var v) env = Var v
+annotateExprFBWW (Lit i) env = Lit i
+annotateExprFBWW (Con c t a) env = Con c t a
+annotateExprFBWW (Prim p t a) env = Prim p t a
+annotateExprFBWW (Lam (id,_) e) env
+ = Lam id (annotateExprFBWW e (delOneFromIdEnv env id))
+
annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
-annotateExprFBWW (CoApp f atom) env = CoApp (annotateExprFBWW f env) atom
+annotateExprFBWW (App f atom) env = App (annotateExprFBWW f env) atom
annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
-annotateExprFBWW (CoSCC lab e) env = CoSCC lab (annotateExprFBWW e env)
-annotateExprFBWW (CoCase e alts) env = CoCase (annotateExprFBWW e env)
+annotateExprFBWW (SCC lab e) env = SCC lab (annotateExprFBWW e env)
+annotateExprFBWW (Case e alts) env = Case (annotateExprFBWW e env)
(annotateAltsFBWW alts env)
-annotateExprFBWW (CoLet bnds e) env = CoLet bnds' (annotateExprFBWW e env')
+annotateExprFBWW (Let bnds e) env = Let bnds' (annotateExprFBWW e env')
where
- (env',bnds') = annotateBindingFBWW env bnds
+ (env',bnds') = annotateBindingFBWW env bnds
-annotateAltsFBWW (CoAlgAlts alts deflt) env = CoAlgAlts alts' deflt'
+annotateAltsFBWW (AlgAlts alts deflt) env = AlgAlts alts' deflt'
where
alts' = [ let
binders' = map fst binders
in (con,binders',annotateExprFBWW e (delManyFromIdEnv env binders'))
| (con,binders,e) <- alts ]
deflt' = annotateDefFBWW deflt env
-annotateAltsFBWW (CoPrimAlts alts deflt) env = CoPrimAlts alts' deflt'
+annotateAltsFBWW (PrimAlts alts deflt) env = PrimAlts alts' deflt'
where
alts' = [ (lit,annotateExprFBWW e env) | (lit,e) <- alts ]
deflt' = annotateDefFBWW deflt env
-annotateDefFBWW CoNoDefault env = CoNoDefault
-annotateDefFBWW (CoBindDefault v e) env
- = CoBindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
+annotateDefFBWW NoDefault env = NoDefault
+annotateDefFBWW (BindDefault v e) env
+ = BindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v)))
-annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,PlainCoreBinding)
+annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,CoreBinding)
annotateBindingFBWW env bnds = (env',bnds')
where
env' = analBind bnds env
bnds' = case bnds of
- CoNonRec (v,_) e -> CoNonRec (fixId v) (annotateExprFBWW e env)
- CoRec bnds -> CoRec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
+ NonRec (v,_) e -> NonRec (fixId v) (annotateExprFBWW e env)
+ Rec bnds -> Rec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ]
fixId v =
(case lookupIdEnv env' v of
Just (IsFB ty@(FBType xs p))
| not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v)
- (addIdFBTypeInfo v (mkFBTypeInfo ty))
+ (addIdFBTypeInfo v (mkFBTypeInfo ty))
_ -> v)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface BinderInfo where
-import Outputable(Outputable)
-data BinderInfo = DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int
-data DuplicationDanger
-data FunOrArg
-data InsideSCC
-argOccurrence :: Int -> BinderInfo
-combineAltsBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo
-combineBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo
-funOccurrence :: Int -> BinderInfo
-getBinderInfoArity :: BinderInfo -> Int
-inlineUnconditionally :: Bool -> BinderInfo -> Bool
-isDupDanger :: DuplicationDanger -> Bool
-isFun :: FunOrArg -> Bool
-markDangerousToDup :: BinderInfo -> BinderInfo
-markInsideSCC :: BinderInfo -> BinderInfo
-markMany :: BinderInfo -> BinderInfo
-oneSafeOcc :: Bool -> BinderInfo -> Bool
-oneTextualOcc :: Bool -> BinderInfo -> Bool
-setBinderInfoArityToZero :: BinderInfo -> BinderInfo
-instance Outputable BinderInfo
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
%************************************************************************
\begin{code}
-
#include "HsVersions.h"
module BinderInfo (
markMany, markDangerousToDup, markInsideSCC,
getBinderInfoArity,
setBinderInfoArityToZero,
-
+
isFun, isDupDanger -- for Simon Marlow deforestation
) where
-IMPORT_Trace -- ToDo: rm (debugging)
+import Ubiq{-uitous-}
-import PlainCore
-import Outputable
import Pretty
-import Util -- for pragmas only
+import Util ( panic )
\end{code}
The @BinderInfo@ describes how a variable is used in a given scope.
-- When combining branches of a case, only report FunOcc if
-- both branches are FunOccs
-data DuplicationDanger
+data DuplicationDanger
= DupDanger -- Inside a non-linear lambda (that is, a lambda which
-- is sure to be instantiated only once), or inside
-- the rhs of an INLINE-pragma'd thing. Either way,
oneTextualOcc _ other = False
\end{code}
-@safeSingleOcc@ detects single occurences of values that are safe to
+@safeSingleOcc@ detects single occurences of values that are safe to
inline, {\em including} ones in an argument position.
\begin{code}
oneSafeOcc :: Bool -> BinderInfo -> Bool
-oneSafeOcc ok_to_dup (OneOcc _ NoDupDanger NotInsideSCC n_alts _)
+oneSafeOcc ok_to_dup (OneOcc _ NoDupDanger NotInsideSCC n_alts _)
= n_alts <= 1 || ok_to_dup
oneSafeOcc _ other = False
\end{code}
= OneOcc posn dup_danger InsideSCC n_alts ar
markInsideSCC other = other
-combineBinderInfo, combineAltsBinderInfo
+combineBinderInfo, combineAltsBinderInfo
:: BinderInfo -> BinderInfo -> BinderInfo
combineBinderInfo DeadCode info2 = info2
combineBinderInfo info1 DeadCode = info1
-combineBinderInfo info1 info2
+combineBinderInfo info1 info2
= ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
combineAltsBinderInfo DeadCode info2 = info2
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ConFold where
-import CoreSyn(CoreAtom, CoreExpr)
-import Id(Id)
-import PrimOps(PrimOp)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-completePrim :: SimplEnv -> PrimOp -> [UniType] -> [CoreAtom Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-
module ConFold ( completePrim ) where
-IMPORT_Trace
-
-import PlainCore
-import TaggedCore
import SimplEnv
import SimplMonad
-import AbsPrel ( trueDataCon, falseDataCon, PrimOp(..), PrimKind
+import PrelInfo ( trueDataCon, falseDataCon, PrimOp(..), PrimRep
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import BasicLit ( mkMachInt, mkMachWord, BasicLit(..) )
-import Id ( Id, getIdUniType )
+import Literal ( mkMachInt, mkMachWord, Literal(..) )
+import Id ( Id, idType )
import Maybes ( Maybe(..) )
import Util
\end{code}
\begin{code}
-completePrim :: SimplEnv
- -> PrimOp -> [OutType] -> [OutAtom]
- -> SmplM OutExpr
+completePrim :: SimplEnv
+ -> PrimOp -> [OutType] -> [OutAtom]
+ -> SmplM OutExpr
\end{code}
In the parallel world, we use _seq_ to control the order in which
don't let the simplifier know that. We also use a special error
value, parError#, which is *not* a bottoming Id, so as far as the
simplifier is concerned, we have to evaluate seq# a before we know
-whether or not y will be evaluated.
+whether or not y will be evaluated.
If we didn't have the extra case, then after inlining the compiler might
see:
evaluate q before p! The "0# ->" case prevents this happening.
By having the parError# branch we make sure that anything in the
other branch stays there!
-
+
This is fine, but we'd like to get rid of the extraneous code. Hence,
we *do* let the simplifier know that seq# is strict in its argument.
As a result, we hope that `a' will be evaluated before seq# is called.
case a of
a' -> let b' = case seq# a of { True -> b; False -> parError# }
- in case b' of ...
+ in case b' of ...
=>
case a of
- a' -> let b' = case True of { True -> b; False -> parError# }
- in case b' of ...
+ a' -> let b' = case True of { True -> b; False -> parError# }
+ in case b' of ...
=>
case a of
a' -> let b' = b
- in case b' of ...
+ in case b' of ...
=>
The second case must never be floated outside of the first!
\begin{code}
-completePrim env SeqOp [ty] [CoLitAtom lit]
- = returnSmpl (CoLit (mkMachInt 1))
+completePrim env SeqOp [ty] [LitArg lit]
+ = returnSmpl (Lit (mkMachInt 1))
-completePrim env op@SeqOp tys@[ty] args@[CoVarAtom var]
+completePrim env op@SeqOp tys@[ty] args@[VarArg var]
= case (lookupUnfolding env var) of
NoUnfoldingDetails -> give_up
- LiteralForm _ -> hooray
- OtherLiteralForm _ -> hooray
- ConstructorForm _ _ _ -> hooray
- OtherConstructorForm _ -> hooray
- GeneralForm _ WhnfForm _ _ -> hooray
- _ -> give_up
+ LitForm _ -> hooray
+ OtherLitForm _ -> hooray
+ ConForm _ _ _ -> hooray
+ OtherConForm _ -> hooray
+ GenForm _ WhnfForm _ _ -> hooray
+ _ -> give_up
where
- give_up = returnSmpl (CoPrim op tys args)
- hooray = returnSmpl (CoLit (mkMachInt 1))
+ give_up = returnSmpl (Prim op tys args)
+ hooray = returnSmpl (Lit (mkMachInt 1))
\end{code}
\begin{code}
completePrim env op tys args
= case args of
- [CoLitAtom (MachChar char_lit)] -> oneCharLit op char_lit
- [CoLitAtom (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
+ [LitArg (MachChar char_lit)] -> oneCharLit op char_lit
+ [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
op int_lit
- [CoLitAtom (MachFloat float_lit)] -> oneFloatLit op float_lit
- [CoLitAtom (MachDouble double_lit)] -> oneDoubleLit op double_lit
- [CoLitAtom other_lit] -> oneLit op other_lit
+ [LitArg (MachFloat float_lit)] -> oneFloatLit op float_lit
+ [LitArg (MachDouble double_lit)] -> oneDoubleLit op double_lit
+ [LitArg other_lit] -> oneLit op other_lit
- [CoLitAtom (MachChar char_lit1),
- CoLitAtom (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2
+ [LitArg (MachChar char_lit1),
+ LitArg (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2
- [CoLitAtom (MachInt int_lit1 True), -- both *signed* literals
- CoLitAtom (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2
+ [LitArg (MachInt int_lit1 True), -- both *signed* literals
+ LitArg (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2
- [CoLitAtom (MachInt int_lit1 False), -- both *unsigned* literals
- CoLitAtom (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
+ [LitArg (MachInt int_lit1 False), -- both *unsigned* literals
+ LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
- [CoLitAtom (MachInt int_lit1 False), -- unsigned+signed (shift ops)
- CoLitAtom (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2
+ [LitArg (MachInt int_lit1 False), -- unsigned+signed (shift ops)
+ LitArg (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2
- [CoLitAtom (MachFloat float_lit1),
- CoLitAtom (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2
+ [LitArg (MachFloat float_lit1),
+ LitArg (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2
- [CoLitAtom (MachDouble double_lit1),
- CoLitAtom (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
+ [LitArg (MachDouble double_lit1),
+ LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
- [CoLitAtom lit, CoVarAtom var] -> litVar op lit var
- [CoVarAtom var, CoLitAtom lit] -> litVar op lit var
+ [LitArg lit, VarArg var] -> litVar op lit var
+ [VarArg var, LitArg lit] -> litVar op lit var
other -> give_up
where
- give_up = returnSmpl (CoPrim op tys args)
+ give_up = returnSmpl (Prim op tys args)
- return_char c = returnSmpl (CoLit (MachChar c))
- return_int i = returnSmpl (CoLit (mkMachInt i))
- return_word i = returnSmpl (CoLit (mkMachWord i))
- return_float f = returnSmpl (CoLit (MachFloat f))
- return_double d = returnSmpl (CoLit (MachDouble d))
- return_lit lit = returnSmpl (CoLit lit)
+ return_char c = returnSmpl (Lit (MachChar c))
+ return_int i = returnSmpl (Lit (mkMachInt i))
+ return_word i = returnSmpl (Lit (mkMachWord i))
+ return_float f = returnSmpl (Lit (MachFloat f))
+ return_double d = returnSmpl (Lit (MachDouble d))
+ return_lit lit = returnSmpl (Lit lit)
return_bool True = returnSmpl trueVal
return_bool False = returnSmpl falseVal
return_prim_case var lit val_if_eq val_if_neq
- = newId (getIdUniType var) `thenSmpl` \ unused_binder ->
+ = newId (idType var) `thenSmpl` \ unused_binder ->
let
result
- = CoCase (CoVar var)
- (CoPrimAlts [(lit,val_if_eq)]
- (CoBindDefault unused_binder val_if_neq))
+ = Case (Var var)
+ (PrimAlts [(lit,val_if_eq)]
+ (BindDefault unused_binder val_if_neq))
in
-- pprTrace "return_prim_case:" (ppr PprDebug result) (
returnSmpl result
-- This stuff turns
-- n ==# 3#
-- into
- -- case n of
+ -- case n of
-- 3# -> True
-- m -> False
--
litVar other_op lit var = give_up
-trueVal = CoCon trueDataCon [] []
-falseVal = CoCon falseDataCon [] []
+trueVal = Con trueDataCon [] []
+falseVal = Con falseDataCon [] []
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FloatIn where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..))
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import UniType(UniType)
-data CoreBinding a b
-data CoreExpr a b
-data Id
-type PlainCoreExpr = CoreExpr Id Id
-type PlainCoreProgram = [CoreBinding Id Id]
-floatInwards :: [CoreBinding Id Id] -> [CoreBinding Id Id]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
#include "HsVersions.h"
module FloatIn (
- floatInwards,
+ floatInwards
-- and to make the interface self-sufficient...
- CoreExpr, CoreBinding, Id,
- PlainCoreProgram(..), PlainCoreExpr(..)
) where
-import Pretty -- ToDo: debugging only
-
-import PlainCore
import AnnCoreSyn
import FreeVars
actually float any bindings downwards from the top-level.
\begin{code}
-floatInwards :: [PlainCoreBinding] -> [PlainCoreBinding]
+floatInwards :: [CoreBinding] -> [CoreBinding]
-floatInwards binds
+floatInwards binds
= map fi_top_bind binds
where
- fi_top_bind (CoNonRec binder rhs)
- = CoNonRec binder (fiExpr [] (freeVars rhs))
- fi_top_bind (CoRec pairs)
- = CoRec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
+ fi_top_bind (NonRec binder rhs)
+ = NonRec binder (fiExpr [] (freeVars rhs))
+ fi_top_bind (Rec pairs)
+ = Rec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ]
\end{code}
%************************************************************************
\begin{code}
type FreeVarsSet = UniqSet Id
-type FloatingBinds = [(PlainCoreBinding, FreeVarsSet)]
+type FloatingBinds = [(CoreBinding, FreeVarsSet)]
-- In dependency order (outermost first)
-- The FreeVarsSet is the free variables of the binding. In the case
fiExpr :: FloatingBinds -- binds we're trying to drop
-- as far "inwards" as possible
-> CoreExprWithFVs -- input expr
- -> PlainCoreExpr -- result
+ -> CoreExpr -- result
-fiExpr to_drop (_,AnnCoVar v) = mkCoLets' to_drop (CoVar v)
+fiExpr to_drop (_,AnnCoVar v) = mkCoLets' to_drop (Var v)
-fiExpr to_drop (_,AnnCoLit k) = mkCoLets' to_drop (CoLit k)
+fiExpr to_drop (_,AnnCoLit k) = mkCoLets' to_drop (Lit k)
fiExpr to_drop (_,AnnCoCon c tys atoms)
- = mkCoLets' to_drop (CoCon c tys atoms)
+ = mkCoLets' to_drop (Con c tys atoms)
fiExpr to_drop (_,AnnCoPrim c tys atoms)
- = mkCoLets' to_drop (CoPrim c tys atoms)
+ = mkCoLets' to_drop (Prim c tys atoms)
\end{code}
Here we are not floating inside lambda (type lambdas are OK):
\begin{code}
-fiExpr to_drop (_,AnnCoLam binders body)
- = mkCoLets' to_drop (mkCoLam binders (fiExpr [] body))
+fiExpr to_drop (_,AnnCoLam binder body)
+ = mkCoLets' to_drop (Lam binder (fiExpr [] body))
fiExpr to_drop (_,AnnCoTyLam tyvar body)
| whnf body
- -- we do not float into type lambdas if they are followed by
- -- a whnf (actually we check for lambdas and constructors).
+ -- we do not float into type lambdas if they are followed by
+ -- a whnf (actually we check for lambdas and constructors).
-- The reason is that a let binding will get stuck
-- in between the type lambda and the whnf and the simplifier
- -- does not know how to pull it back out from a type lambda.
+ -- does not know how to pull it back out from a type lambda.
-- Ex:
-- let v = ...
-- in let f = /\t -> \a -> ...
= mkCoLets' to_drop (CoTyLam tyvar (fiExpr [] body))
| otherwise
= CoTyLam tyvar (fiExpr to_drop body)
- where
+ where
whnf :: CoreExprWithFVs -> Bool
whnf (_,AnnCoLit _) = True
whnf (_,AnnCoCon _ _ _) = True
whnf (_,AnnCoTyLam _ e) = whnf e
whnf (_,AnnCoSCC _ e) = whnf e
whnf _ = False
-
\end{code}
Applications: we could float inside applications, but it's probably
based).
\begin{code}
fiExpr to_drop (_,AnnCoApp fun atom)
- = mkCoLets' to_drop (CoApp (fiExpr [] fun) atom)
+ = mkCoLets' to_drop (App (fiExpr [] fun) atom)
fiExpr to_drop (_,AnnCoTyApp expr ty)
= CoTyApp (fiExpr to_drop expr) ty
We don't float lets inwards past an SCC.
-ToDo: CoSCC: {\em should} keep info on current cc, and when passing
+ToDo: SCC: {\em should} keep info on current cc, and when passing
one, if it is not the same, annotate all lets in binds with current
cc, change current cc to the new one and float binds into expr.
\begin{code}
fiExpr to_drop (_, AnnCoSCC cc expr)
- = mkCoLets' to_drop (CoSCC cc (fiExpr [] expr))
+ = mkCoLets' to_drop (SCC cc (fiExpr [] expr))
\end{code}
-For @CoLets@, the possible ``drop points'' for the \tr{to_drop}
-bindings are: (a)~in the body, (b1)~in the RHS of a CoNonRec binding,
-or~(b2), in each of the RHSs of the pairs of a @CoRec@.
+For @Lets@, the possible ``drop points'' for the \tr{to_drop}
+bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
+or~(b2), in each of the RHSs of the pairs of a @Rec@.
Note that we do {\em weird things} with this let's binding. Consider:
\begin{verbatim}
rhs_fvs = freeVarsOf rhs
body_fvs = freeVarsOf body
- ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
+ ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop
new_to_drop = body_binds ++ -- the bindings used only in the body
- [(CoNonRec id rhs', rhs_fvs')] ++ -- the new binding itself
- shared_binds -- the bindings used both in rhs and body
+ [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself
+ shared_binds -- the bindings used both in rhs and body
-- Push rhs_binds into the right hand side of the binding
rhs' = fiExpr rhs_binds rhs
rhss_fvs = map freeVarsOf rhss
body_fvs = freeVarsOf body
- (body_binds:rhss_binds, shared_binds)
- = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
+ (body_binds:rhss_binds, shared_binds)
+ = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop
new_to_drop = -- the bindings used only in the body
- body_binds ++
- -- the new binding itself
- [(CoRec (fi_bind rhss_binds bindings), rhs_fvs')] ++
- -- the bindings used both in rhs and body or in more than one rhs
- shared_binds
+ body_binds ++
+ -- the new binding itself
+ [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
+ -- the bindings used both in rhs and body or in more than one rhs
+ shared_binds
- rhs_fvs' = unionUniqSets (unionManyUniqSets rhss_fvs)
- (unionManyUniqSets (map floatedBindsFVs rhss_binds))
+ rhs_fvs' = unionUniqSets (unionManyUniqSets rhss_fvs)
+ (unionManyUniqSets (map floatedBindsFVs rhss_binds))
-- Push rhs_binds into the right hand side of the binding
fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss
-> [(Id, CoreExprWithFVs)]
- -> [(Id, PlainCoreExpr)]
+ -> [(Id, CoreExpr)]
fi_bind to_drops pairs
= [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip pairs to_drops ]
\end{code}
-For @CoCase@, the possible ``drop points'' for the \tr{to_drop}
+For @Case@, the possible ``drop points'' for the \tr{to_drop}
bindings are: (a)~inside the scrutinee, (b)~inside one of the
alternatives/default [default FVs always {\em first}!].
in
case (sepBindsByDropPoint drop_pts_fvs to_drop)
of (scrut_drops : deflt_drops : alts_drops, drop_here) ->
- mkCoLets' drop_here (CoCase (fiExpr scrut_drops scrut)
- (fi_alts deflt_drops alts_drops alts))
-
+ mkCoLets' drop_here (Case (fiExpr scrut_drops scrut)
+ (fi_alts deflt_drops alts_drops alts))
+
where
----------------------------
-- pin default FVs on first!
----------------------------
fi_alts to_drop_deflt to_drop_alts (AnnCoAlgAlts alts deflt)
- = CoAlgAlts
+ = AlgAlts
[ (con, params, fiExpr to_drop rhs)
| ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ]
(fi_default to_drop_deflt deflt)
fi_alts to_drop_deflt to_drop_alts (AnnCoPrimAlts alts deflt)
- = CoPrimAlts
+ = PrimAlts
[ (lit, fiExpr to_drop rhs)
| ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ]
(fi_default to_drop_deflt deflt)
- fi_default to_drop AnnCoNoDefault = CoNoDefault
- fi_default to_drop (AnnCoBindDefault b e) = CoBindDefault b (fiExpr to_drop e)
+ fi_default to_drop AnnCoNoDefault = NoDefault
+ fi_default to_drop (AnnCoBindDefault b e) = BindDefault b (fiExpr to_drop e)
\end{code}
%************************************************************************
-> FloatingBinds -- candidate floaters
-> ([FloatingBinds], -- floaters that *can* be floated into
-- the corresponding drop point
- FloatingBinds) -- everything else, bindings which must
+ FloatingBinds) -- everything else, bindings which must
-- not be floated inside any drop point
sepBindsByDropPoint drop_pts []
= let
(per_drop_pt, must_stay_here, _)
--= sep drop_pts emptyUniqSet{-fvs of prev drop_pts-} floaters
- = split' drop_pts floaters [] empty_boxes
- empty_boxes = take (length drop_pts) (repeat [])
-
+ = split' drop_pts floaters [] empty_boxes
+ empty_boxes = take (length drop_pts) (repeat [])
+
in
(map reverse per_drop_pt, reverse must_stay_here)
where
-- only in a or unused
split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
| all (\b -> {-b `elementOfUniqSet` a &&-}
- not (b `elementOfUniqSet` (unionManyUniqSets as)))
- (bindersOf (fst bind))
+ not (b `elementOfUniqSet` (unionManyUniqSets as)))
+ (bindersOf (fst bind))
= split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes)
where
- a' = a `unionUniqSets` fvsOfBind bind
+ a' = a `unionUniqSets` fvsOfBind bind
- -- not in a
+ -- not in a
split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
| all (\b -> not (b `elementOfUniqSet` a)) (bindersOf (fst bind))
= split' (a:as') binds mult_branch' (drop_box_a:drop_boxes')
where
- (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
+ (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
-- in a and in as
split' aas@(a:as) (bind:binds) mult_branch drop_boxes
= split' aas' binds (bind : mult_branch) drop_boxes
- where
- aas' = map (unionUniqSets (fvsOfBind bind)) aas
+ where
+ aas' = map (unionUniqSets (fvsOfBind bind)) aas
-------------------------
fvsOfBind (_,fvs) = fvs
---floatedBindsFVs ::
+--floatedBindsFVs ::
floatedBindsFVs binds = foldr unionUniqSets emptyUniqSet (map snd binds)
---mkCoLets' :: [FloatingBinds] -> PlainCoreExpr -> PlainCoreExpr
+--mkCoLets' :: [FloatingBinds] -> CoreExpr -> CoreExpr
mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FloatOut where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-floatOutwards :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[FloatOut]{Float bindings outwards (towards the top level)}
module FloatOut ( floatOutwards ) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
-import PlainCore
-
-import BasicLit ( BasicLit(..), PrimKind )
+import Literal ( Literal(..) )
import CmdLineOpts ( GlobalSwitch(..) )
import CostCentre ( dupifyCC, CostCentre )
import SetLevels
import Id ( eqId )
-import IdEnv
import Maybes ( Maybe(..), catMaybes, maybeToBool )
-import SplitUniq
+import UniqSupply
import Util
\end{code}
\begin{code}
-type LevelledExpr = CoreExpr (Id, Level) Id
-type LevelledBind = CoreBinding (Id, Level) Id
+type LevelledExpr = GenCoreExpr (Id, Level) Id
+type LevelledBind = GenCoreBinding (Id, Level) Id
type FloatingBind = (Level, Floater)
type FloatingBinds = [FloatingBind]
-data Floater = LetFloater PlainCoreBinding
+data Floater = LetFloater CoreBinding
- | CaseFloater (PlainCoreExpr -> PlainCoreExpr)
+ | CaseFloater (CoreExpr -> CoreExpr)
-- Give me a right-hand side of the
-- (usually single) alternative, and
-- I'll build the case
\begin{code}
floatOutwards :: (GlobalSwitch -> Bool) -- access to all global cmd-line opts
- -> SplitUniqSupply
- -> PlainCoreProgram
- -> PlainCoreProgram
+ -> UniqSupply
+ -> [CoreBinding]
+ -> [CoreBinding]
floatOutwards sw_chker us pgm
= case (setLevels pgm sw_chker us) of { annotated_w_levels ->
concat final_toplev_binds_s
}}
-floatTopBind sw bind@(CoNonRec _ _)
+floatTopBind sw bind@(NonRec _ _)
= case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
(fs, floatsToBinds floats ++ [bind'])
}
-floatTopBind sw bind@(CoRec _)
- = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, CoRec pairs', _) ->
+floatTopBind sw bind@(Rec _)
+ = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, Rec pairs', _) ->
-- Actually floats will be empty
--false:ASSERT(null floats)
- (fs, [CoRec (floatsToBindPairs floats ++ pairs')])
+ (fs, [Rec (floatsToBindPairs floats ++ pairs')])
}
\end{code}
\begin{code}
-floatBind :: (GlobalSwitch -> Bool)
+floatBind :: (GlobalSwitch -> Bool)
-> IdEnv Level
-> Level
-> LevelledBind
- -> (FloatStats, FloatingBinds, PlainCoreBinding, IdEnv Level)
+ -> (FloatStats, FloatingBinds, CoreBinding, IdEnv Level)
-floatBind sw env lvl (CoNonRec (name,level) rhs)
+floatBind sw env lvl (NonRec (name,level) rhs)
= case (floatExpr sw env level rhs) of { (fs, rhs_floats, rhs') ->
-- A good dumping point
case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
- (fs, rhs_floats',CoNonRec name (install heres rhs'), addOneToIdEnv env name level)
+ (fs, rhs_floats',NonRec name (install heres rhs'), addOneToIdEnv env name level)
}}
-
-floatBind sw env lvl bind@(CoRec pairs)
+
+floatBind sw env lvl bind@(Rec pairs)
= case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
if not (isTopLvl bind_level) then
-- Standard case
- (sum_stats fss, concat rhss_floats, CoRec new_pairs, new_env)
+ (sum_stats fss, concat rhss_floats, Rec new_pairs, new_env)
else
- {- In a recursive binding, destined for the top level (only),
- the rhs floats may contain
+ {- In a recursive binding, destined for the top level (only),
+ the rhs floats may contain
references to the bound things. For example
f = ...(let v = ...f... in b) ...
v = ...f...
f = ... b ...
- and hence we must (pessimistically) make all the floats recursive
+ and hence we must (pessimistically) make all the floats recursive
with the top binding. Later dependency analysis will unravel it.
-}
(sum_stats fss,
- [],
- CoRec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
+ [],
+ Rec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
new_env)
}
%************************************************************************
\begin{code}
-floatExpr :: (GlobalSwitch -> Bool)
+floatExpr :: (GlobalSwitch -> Bool)
-> IdEnv Level
- -> Level
+ -> Level
-> LevelledExpr
- -> (FloatStats, FloatingBinds, PlainCoreExpr)
+ -> (FloatStats, FloatingBinds, CoreExpr)
-floatExpr sw env _ (CoVar v) = (zero_stats, [], CoVar v)
+floatExpr sw env _ (Var v) = (zero_stats, [], Var v)
-floatExpr sw env _ (CoLit l) = (zero_stats, [], CoLit l)
+floatExpr sw env _ (Lit l) = (zero_stats, [], Lit l)
-floatExpr sw env _ (CoPrim op ty as) = (zero_stats, [], CoPrim op ty as)
-floatExpr sw env _ (CoCon con ty as) = (zero_stats, [], CoCon con ty as)
+floatExpr sw env _ (Prim op ty as) = (zero_stats, [], Prim op ty as)
+floatExpr sw env _ (Con con ty as) = (zero_stats, [], Con con ty as)
-floatExpr sw env lvl (CoApp e a)
+floatExpr sw env lvl (App e a)
= case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
- (fs, floating_defns, CoApp e' a) }
-
+ (fs, floating_defns, App e' a) }
+
floatExpr sw env lvl (CoTyApp e ty)
= case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
(fs, floating_defns, CoTyApp e' ty) }
(fs, floats', CoTyLam tv (install heres e'))
}}
-floatExpr sw env lvl (CoLam args@((_,incd_lvl):_) rhs)
+floatExpr sw env lvl (Lam (arg,incd_lvl) rhs)
= let
- args' = map fst args
- new_env = growIdEnvList env args
+ new_env = addOneToIdEnv env arg incd_lvl
in
case (floatExpr sw new_env incd_lvl rhs) of { (fs, floats, rhs') ->
(add_to_stats fs floats',
floats',
- mkCoLam args' (install heres rhs'))
+ Lam args' (install heres rhs'))
}}
-floatExpr sw env lvl (CoSCC cc expr)
+floatExpr sw env lvl (SCC cc expr)
= case (floatExpr sw env lvl expr) of { (fs, floating_defns, expr') ->
let
-- annotate bindings floated outwards past an scc expression
annotated_defns = annotate (dupifyCC cc) floating_defns
in
- (fs, annotated_defns, CoSCC cc expr') }
+ (fs, annotated_defns, SCC cc expr') }
where
annotate :: CostCentre -> FloatingBinds -> FloatingBinds
annotate dupd_cc defn_groups
= [ (level, ann_bind floater) | (level, floater) <- defn_groups ]
where
- ann_bind (LetFloater (CoNonRec binder rhs))
- = LetFloater (CoNonRec binder (ann_rhs rhs))
+ ann_bind (LetFloater (NonRec binder rhs))
+ = LetFloater (NonRec binder (ann_rhs rhs))
- ann_bind (LetFloater (CoRec pairs))
- = LetFloater (CoRec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
+ ann_bind (LetFloater (Rec pairs))
+ = LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
- ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> CoSCC dupd_cc (fn rhs) )
+ ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> SCC dupd_cc (fn rhs) )
- ann_rhs (CoLam args e) = CoLam args (ann_rhs e)
- ann_rhs (CoTyLam tv e) = CoTyLam tv (ann_rhs e)
- ann_rhs rhs@(CoCon _ _ _)= rhs -- no point in scc'ing WHNF data
- ann_rhs rhs = CoSCC dupd_cc rhs
+ ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
+ ann_rhs (CoTyLam tv e) = CoTyLam tv (ann_rhs e)
+ ann_rhs rhs@(Con _ _ _)= rhs -- no point in scc'ing WHNF data
+ ann_rhs rhs = SCC dupd_cc rhs
-- Note: Nested SCC's are preserved for the benefit of
-- cost centre stack profiling (Durham)
-floatExpr sw env lvl (CoLet bind body)
+floatExpr sw env lvl (Let bind body)
= case (floatBind sw env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
case (floatExpr sw new_env lvl body) of { (fse, body_floats, body') ->
(add_stats fsb fse,
where
bind_lvl = getBindLevel bind
-floatExpr sw env lvl (CoCase scrut alts)
+floatExpr sw env lvl (Case scrut alts)
= case (floatExpr sw env lvl scrut) of { (fse, fde, scrut') ->
- case (scrut', float_alts alts) of
+ case (scrut', float_alts alts) of
{- CASE-FLOATING DROPPED FOR NOW. (SLPJ 7/2/94)
- (CoVar scrut_var, (fda, CoAlgAlts [(con,bs,rhs')] CoNoDefault))
+ (Var scrut_var, (fda, AlgAlts [(con,bs,rhs')] NoDefault))
| scrut_var_lvl `ltMajLvl` lvl ->
-- Candidate for case floater; scrutinising a variable; it can
where
case_floater = (scrut_var_lvl, CaseFloater fn)
- fn body = CoCase scrut' (CoAlgAlts [(con,bs,body)] CoNoDefault)
+ fn body = Case scrut' (AlgAlts [(con,bs,body)] NoDefault)
scrut_var_lvl = case lookupIdEnv env scrut_var of
Nothing -> Level 0 0
Just lvl -> unTopify lvl
END OF CASE FLOATING DROPPED -}
- (_, (fsa, fda, alts')) ->
+ (_, (fsa, fda, alts')) ->
- (add_stats fse fsa, fda ++ fde, CoCase scrut' alts')
+ (add_stats fse fsa, fda ++ fde, Case scrut' alts')
}
where
incd_lvl = incMinorLvl lvl
{- OMITTED
We don't want to be too keen about floating lets out of case alternatives
because they may benefit from seeing the evaluation done by the case.
-
+
The main reason for doing this is to allocate in fewer larger blocks
but that's really an STG-level issue.
case alts of
-- Just one alternative, then dump only
-- what *has* to be dumped
- CoAlgAlts [_] CoNoDefault -> partitionByLevel
- CoAlgAlts [] (CoBindDefault _ _) -> partitionByLevel
- CoPrimAlts [_] CoNoDefault -> partitionByLevel
- CoPrimAlts [] (CoBindDefault _ _) -> partitionByLevel
+ AlgAlts [_] NoDefault -> partitionByLevel
+ AlgAlts [] (BindDefault _ _) -> partitionByLevel
+ PrimAlts [_] NoDefault -> partitionByLevel
+ PrimAlts [] (BindDefault _ _) -> partitionByLevel
-- If there's more than one alternative, then
-- this is a dumping point
other -> partitionByMajorLevel
-}
- float_alts (CoAlgAlts alts deflt)
+ float_alts (AlgAlts alts deflt)
= case (float_deflt deflt) of { (fsd, fdd, deflt') ->
case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
(foldr add_stats fsd fsas,
concat fdas ++ fdd,
- CoAlgAlts alts' deflt') }}
+ AlgAlts alts' deflt') }}
- float_alts (CoPrimAlts alts deflt)
+ float_alts (PrimAlts alts deflt)
= case (float_deflt deflt) of { (fsd, fdd, deflt') ->
case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
(foldr add_stats fsd fsas,
concat fdas ++ fdd,
- CoPrimAlts alts' deflt') }}
+ PrimAlts alts' deflt') }}
-------------
float_alg_alt (con, bs, rhs)
(fs, rhs_floats', (lit, install heres rhs')) }}
--------------
- float_deflt CoNoDefault = (zero_stats, [], CoNoDefault)
+ float_deflt NoDefault = (zero_stats, [], NoDefault)
- float_deflt (CoBindDefault (b,lvl) rhs)
+ float_deflt (BindDefault (b,lvl) rhs)
= case (floatExpr sw new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
- (fs, rhs_floats', CoBindDefault b (install heres rhs')) }}
+ (fs, rhs_floats', BindDefault b (install heres rhs')) }}
where
- new_env = addOneToIdEnv env b lvl
+ new_env = addOneToIdEnv env b lvl
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-getBindLevel (CoNonRec (_, lvl) _) = lvl
-getBindLevel (CoRec (((_,lvl), _) : _)) = lvl
+getBindLevel (NonRec (_, lvl) _) = lvl
+getBindLevel (Rec (((_,lvl), _) : _)) = lvl
\end{code}
\begin{code}
FloatingBinds) -- The rest
-partitionByMajorLevel ctxt_lvl defns
+partitionByMajorLevel ctxt_lvl defns
= partition float_further defns
where
float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl ||
\end{code}
\begin{code}
-floatsToBinds :: FloatingBinds -> [PlainCoreBinding]
+floatsToBinds :: FloatingBinds -> [CoreBinding]
floatsToBinds floats = map get_bind floats
where
get_bind (_, LetFloater bind) = bind
get_bind (_, CaseFloater _) = panic "floatsToBinds"
-floatsToBindPairs :: FloatingBinds -> [(Id,PlainCoreExpr)]
+floatsToBindPairs :: FloatingBinds -> [(Id,CoreExpr)]
floatsToBindPairs floats = concat (map mk_pairs floats)
where
- mk_pairs (_, LetFloater (CoRec pairs)) = pairs
- mk_pairs (_, LetFloater (CoNonRec binder rhs)) = [(binder,rhs)]
+ mk_pairs (_, LetFloater (Rec pairs)) = pairs
+ mk_pairs (_, LetFloater (NonRec binder rhs)) = [(binder,rhs)]
mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs"
-install :: FloatingBinds -> PlainCoreExpr -> PlainCoreExpr
+install :: FloatingBinds -> CoreExpr -> CoreExpr
install defn_groups expr
= foldr install_group expr defn_groups
where
- install_group (_, LetFloater defns) body = CoLet defns body
+ install_group (_, LetFloater defns) body = Let defns body
install_group (_, CaseFloater fn) body = fn body
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FoldrBuildWW where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-mkFoldrBuildWW :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
IMPORT_Trace
import Outputable
-import Pretty
-import AbsUniType ( alpha_tv, cloneTyVarFromTemplate, mkTyVarTy,
- splitTypeWithDictsAsArgs, eqTyCon, mkForallTy,
- alpha_tyvar, alpha_ty, alpha, TyVarTemplate
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
- )
-import UniType ( UniType(..) ) -- **** CAN SEE THE CONSTRUCTORS ****
-import PlainCore
-import Unique ( runBuiltinUs )
+import Pretty
+import Type ( cloneTyVarFromTemplate, mkTyVarTy,
+ splitTypeWithDictsAsArgs, eqTyCon, mkForallTy )
+import TysPrim ( alphaTy )
+import TyVar ( alphaTyVar )
+
+import Type ( Type(..) ) -- **** CAN SEE THE CONSTRUCTORS ****
+import UniqSupply ( runBuiltinUs )
import WwLib -- share the same monad (is this eticit ?)
-import AbsPrel ( listTyCon, mkListTy, nilDataCon, consDataCon,
- foldrId, mkBuild, mkFoldr, buildId,
- mkFunTy
+import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon,
+ foldrId, buildId
)
import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
- replaceIdInfo, mkSysLocal, getIdUniType
+ replaceIdInfo, mkSysLocal, idType
)
-import IdInfo
+import IdInfo
import Maybes
import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
import Util
\end{code}
\begin{code}
-mkFoldrBuildWW
- :: (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> PlainCoreProgram
- -> PlainCoreProgram
-mkFoldrBuildWW switch us top_binds =
+mkFoldrBuildWW
+ :: (GlobalSwitch -> Bool)
+ -> UniqSupply
+ -> [CoreBinding]
+ -> [CoreBinding]
+mkFoldrBuildWW switch us top_binds =
(mapWw wwBind top_binds `thenWw` \ top_binds2 ->
returnWw (concat top_binds2)) us switch
\end{code}
\begin{code}
-wwBind :: PlainCoreBinding -> WwM [PlainCoreBinding]
-wwBind (CoNonRec bndr expr)
+wwBind :: CoreBinding -> WwM [CoreBinding]
+wwBind (NonRec bndr expr)
= try_split_bind bndr expr `thenWw` \ re ->
- returnWw [CoNonRec bnds expr | (bnds,expr) <- re]
-wwBind (CoRec binds)
+ returnWw [NonRec bnds expr | (bnds,expr) <- re]
+wwBind (Rec binds)
= mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds `thenWw` \ res ->
- returnWw [CoRec (concat res)]
-
-wwExpr :: PlainCoreExpr -> WwM PlainCoreExpr
-wwExpr e@(CoVar _) = returnWw e
-wwExpr e@(CoLit _) = returnWw e
-wwExpr e@(CoCon _ _ _) = returnWw e
-wwExpr e@(CoPrim _ _ _) = returnWw e
-wwExpr (CoLam ids e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (CoLam ids e')
-wwExpr (CoTyLam tyvar e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (CoTyLam tyvar e')
-wwExpr (CoApp f atom) =
- wwExpr f `thenWw` \ f' ->
- returnWw (CoApp f atom)
-wwExpr (CoTyApp f ty) =
- wwExpr f `thenWw` \ f' ->
- returnWw (CoTyApp f' ty)
-wwExpr (CoSCC lab e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (CoSCC lab e')
-wwExpr (CoLet bnds e) =
- wwExpr e `thenWw` \ e' ->
- wwBind bnds `thenWw` \ bnds' ->
- returnWw (foldr CoLet e' bnds')
-wwExpr (CoCase e alts) =
- wwExpr e `thenWw` \ e' ->
- wwAlts alts `thenWw` \ alts' ->
- returnWw (CoCase e' alts')
-
-wwAlts (CoAlgAlts alts deflt) =
- mapWw (\(con,binders,e) ->
- wwExpr e `thenWw` \ e' ->
- returnWw (con,binders,e')) alts `thenWw` \ alts' ->
- wwDef deflt `thenWw` \ deflt' ->
- returnWw (CoAlgAlts alts' deflt)
-wwAlts (CoPrimAlts alts deflt) =
- mapWw (\(lit,e) ->
- wwExpr e `thenWw` \ e' ->
- returnWw (lit,e')) alts `thenWw` \ alts' ->
- wwDef deflt `thenWw` \ deflt' ->
- returnWw (CoPrimAlts alts' deflt)
-
-wwDef e@CoNoDefault = returnWw e
-wwDef (CoBindDefault v e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (CoBindDefault v e')
+ returnWw [Rec (concat res)]
+
+wwExpr :: CoreExpr -> WwM CoreExpr
+wwExpr e@(Var _) = returnWw e
+wwExpr e@(Lit _) = returnWw e
+wwExpr e@(Con _ _ _) = returnWw e
+wwExpr e@(Prim _ _ _) = returnWw e
+wwExpr (Lam ids e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (Lam ids e')
+wwExpr (CoTyLam tyvar e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (CoTyLam tyvar e')
+wwExpr (App f atom) =
+ wwExpr f `thenWw` \ f' ->
+ returnWw (App f atom)
+wwExpr (CoTyApp f ty) =
+ wwExpr f `thenWw` \ f' ->
+ returnWw (CoTyApp f' ty)
+wwExpr (SCC lab e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (SCC lab e')
+wwExpr (Let bnds e) =
+ wwExpr e `thenWw` \ e' ->
+ wwBind bnds `thenWw` \ bnds' ->
+ returnWw (foldr Let e' bnds')
+wwExpr (Case e alts) =
+ wwExpr e `thenWw` \ e' ->
+ wwAlts alts `thenWw` \ alts' ->
+ returnWw (Case e' alts')
+
+wwAlts (AlgAlts alts deflt) =
+ mapWw (\(con,binders,e) ->
+ wwExpr e `thenWw` \ e' ->
+ returnWw (con,binders,e')) alts `thenWw` \ alts' ->
+ wwDef deflt `thenWw` \ deflt' ->
+ returnWw (AlgAlts alts' deflt)
+wwAlts (PrimAlts alts deflt) =
+ mapWw (\(lit,e) ->
+ wwExpr e `thenWw` \ e' ->
+ returnWw (lit,e')) alts `thenWw` \ alts' ->
+ wwDef deflt `thenWw` \ deflt' ->
+ returnWw (PrimAlts alts' deflt)
+
+wwDef e@NoDefault = returnWw e
+wwDef (BindDefault v e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (BindDefault v e')
\end{code}
\begin{code}
-try_split_bind :: Id -> PlainCoreExpr -> WwM [(Id,PlainCoreExpr)]
-try_split_bind id expr =
+try_split_bind :: Id -> CoreExpr -> WwM [(Id,CoreExpr)]
+try_split_bind id expr =
wwExpr expr `thenWw` \ expr' ->
case getFBType (getIdFBTypeInfo id) of
- Just (FBType consum prod)
- | FBGoodProd == prod ->
+ Just (FBType consum prod)
+ | FBGoodProd == prod ->
{- || any (== FBGoodConsum) consum -}
let
- (big_args,args,body) = digForLambdas expr'
+ (use_args,big_args,args,body) = digForLambdas expr'
in
- if length args /= length consum -- funny number of arguments
- then returnWw [(id,expr')]
- else
- -- f /\ t1 .. tn \ v1 .. vn -> e
- -- ===>
- -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
- -- f /\ t1 .. tn \ v1 .. vn
+ if length args /= length consum -- funny number of arguments
+ then returnWw [(id,expr')]
+ else
+ -- f /\ t1 .. tn \ v1 .. vn -> e
+ -- ===>
+ -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
+ -- f /\ t1 .. tn \ v1 .. vn
-- -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
pprTrace "WW:" (ppr PprDebug id) (returnWw ())
`thenWw` \ () ->
- getUniqueWw `thenWw` \ ty_new_uq ->
- getUniqueWw `thenWw` \ worker_new_uq ->
- getUniqueWw `thenWw` \ c_new_uq ->
- getUniqueWw `thenWw` \ n_new_uq ->
+ getUniqueWw `thenWw` \ ty_new_uq ->
+ getUniqueWw `thenWw` \ worker_new_uq ->
+ getUniqueWw `thenWw` \ c_new_uq ->
+ getUniqueWw `thenWw` \ n_new_uq ->
let
-- The *new* type
- n_ty = alpha_ty
- n_ty_templ = alpha
+ n_ty = alphaTy
+ n_ty_templ = alphaTy
- (templ,arg_tys,res) = splitTypeWithDictsAsArgs (getIdUniType id)
+ (templ,arg_tys,res) = splitTypeWithDictsAsArgs (idType id)
expr_ty = getListTy res
- getListTy res = case res of
- UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
- _ -> panic "Trying to split a non List datatype into Worker/Wrapper"
+ getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of
+ UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
+ _ -> panic "Trying to split a non List datatype into Worker/Wrapper"-}
- c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
- c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
+ c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
+ c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
- worker_ty = mkForallTy (templ ++ [alpha_tv])
+ worker_ty = mkForallTy (templ ++ [alphaTyVar])
(foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
wrapper_id = id `replaceIdInfo`
(getIdInfo id `addInfo_UF`
-- TODO : CHECK if mkWorkerId is thr
-- right function to use ..
-- Now the bodies
-
+
c_id = mkSysLocal SLIT("_fbww") c_new_uq c_ty mkUnknownSrcLoc
n_id = mkSysLocal SLIT("_fbww") n_new_uq n_ty mkUnknownSrcLoc
- worker_rhs = foldr CoTyLam
- (mkCoLam (args++[c_id,n_id]) worker_body)
- (big_args ++ [alpha_tyvar])
+ worker_rhs
+ = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
+
worker_body = runBuiltinUs (
- mkCoApps (mkCoTyApps (CoVar foldrId) [expr_ty, n_ty])
- [CoVar c_id,CoVar n_id,body])
- wrapper_rhs = foldr CoTyLam
- (mkCoLam (args) wrapper_body)
- big_args
+ mkCoApps
+ (Var foldrId `CoTyApp` expr_ty `CoTyApp` n_ty `App`
+ VarArg c_id `App` VarArg n_id)
+ [body])
+ wrapper_rhs = mkLam big_args args wrapper_body
+
wrapper_body = runBuiltinUs (
- mkCoApps (mkCoTyApp (CoVar buildId) expr_ty)
- [CoTyLam alpha_tyvar (mkCoLam [c_id,n_id]
- (foldl CoApp
- (mkCoTyApps (CoVar worker_id)
- [mkTyVarTy t | t <- big_args ++ [alpha_tyvar]])
- (map CoVarAtom (args++[c_id,n_id]))))])
+ mkCoApps (CoTyApp (Var buildId) expr_ty)
+ [mkLam [alphaTyVar] [c_id,n_id]
+ (foldl App
+ (mkCoTyApps (Var worker_id)
+ [mkTyVarTy t | t <- big_args ++ [alphaTyVar]])
+ (map VarArg (args++[c_id,n_id])))])
in
if length args /= length arg_tys ||
- length big_args /= length templ
+ length big_args /= length templ
then panic "LEN PROBLEM"
else
- returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
+ returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
_ -> returnWw [(id,expr')]
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface LiberateCase where
-import CoreSyn(CoreBinding)
-import Id(Id)
-liberateCase :: Int -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
module LiberateCase ( liberateCase ) where
-IMPORT_Trace
-
+import CoreUnfold ( UnfoldingGuidance(..) )
import Id ( localiseId, toplevelishId{-debugging-} )
-import IdEnv
import Maybes
import Outputable
-import PlainCore
import Pretty
-import SimplEnv ( UnfoldingGuidance(..) )
import Util
\end{code}
\begin{verbatim}
f = \ t -> case v of
- V a b -> a : f t
+ V a b -> a : f t
\end{verbatim}
=> the inner f is replaced.
f = \ t -> case v of
V a b -> a : (letrec
f = \ t -> case v of
- V a b -> a : f t
- in f) t
+ V a b -> a : f t
+ in f) t
\end{verbatim}
(note the NEED for shadowing)
\begin{verbatim}
f = \ t -> case v of
V a b -> a : (letrec
- f = \ t -> a : f t
+ f = \ t -> a : f t
in f t)
\begin{verbatim}
Better code, because 'a' is free inside the inner letrec, rather
let h = ...
in ...
\end{verbatim}
-Here, the level of @f@ is zero, the level of @g@ is one,
+Here, the level of @f@ is zero, the level of @g@ is one,
and the level of @h@ is zero (NB not one).
\begin{code}
-type LibCaseLevel = Int
+type LibCaseLevel = Int
topLevel :: LibCaseLevel
topLevel = 0
\end{code}
\begin{code}
-data LibCaseEnv
+data LibCaseEnv
= LibCaseEnv
Int -- Bomb-out size for deciding if
-- potential liberatees are too big.
-- (top-level and imported things have
-- a level of zero)
- (IdEnv PlainCoreBinding)-- Binds *only* recursively defined
+ (IdEnv CoreBinding)-- Binds *only* recursively defined
-- Ids, to their own binding group,
-- and *only* in their own RHSs
Programs
~~~~~~~~
\begin{code}
-liberateCase :: Int -> [PlainCoreBinding] -> [PlainCoreBinding]
+liberateCase :: Int -> [CoreBinding] -> [CoreBinding]
liberateCase bomb_size prog
= do_prog (initEnv bomb_size) prog
where
~~~~~~~~
\begin{code}
-libCaseBind :: LibCaseEnv -> PlainCoreBinding -> (LibCaseEnv, PlainCoreBinding)
+libCaseBind :: LibCaseEnv -> CoreBinding -> (LibCaseEnv, CoreBinding)
-libCaseBind env (CoNonRec binder rhs)
- = (addBinders env [binder], CoNonRec binder (libCase env rhs))
+libCaseBind env (NonRec binder rhs)
+ = (addBinders env [binder], NonRec binder (libCase env rhs))
-libCaseBind env (CoRec pairs)
- = (env_body, CoRec pairs')
+libCaseBind env (Rec pairs)
+ = (env_body, Rec pairs')
where
(binders, rhss) = unzip pairs
-- copy of the original binding. In particular, the original
-- binding might have been for a TopLevId, and this copy clearly
-- will not be top-level!
-
+
-- It is enough to change just the binder, because subsequent
-- simplification will propagate the right info from the binder.
\begin{code}
libCase :: LibCaseEnv
- -> PlainCoreExpr
- -> PlainCoreExpr
+ -> CoreExpr
+ -> CoreExpr
-libCase env (CoLit lit) = CoLit lit
-libCase env (CoVar v) = mkCoLetsNoUnboxed (libCaseId env v) (CoVar v)
-libCase env (CoApp fun arg) = mkCoLetsNoUnboxed (libCaseAtom env arg) (CoApp (libCase env fun) arg)
+libCase env (Lit lit) = Lit lit
+libCase env (Var v) = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
+libCase env (App fun arg) = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
libCase env (CoTyApp fun ty) = CoTyApp (libCase env fun) ty
-libCase env (CoCon con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (CoCon con tys args)
-libCase env (CoPrim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (CoPrim op tys args)
+libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
+libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
libCase env (CoTyLam tyvar body) = CoTyLam tyvar (libCase env body)
-libCase env (CoSCC cc body) = CoSCC cc (libCase env body)
+libCase env (SCC cc body) = SCC cc (libCase env body)
-libCase env (CoLam binders body)
- = CoLam binders (libCase env' body)
- where
- env' = addBinders env binders
+libCase env (Lam binder body)
+ = Lam binder (libCase (addBinders env [binder]) body)
-libCase env (CoLet bind body)
- = CoLet bind' (libCase env_body body)
+libCase env (Let bind body)
+ = Let bind' (libCase env_body body)
where
(env_body, bind') = libCaseBind env bind
-libCase env (CoCase scrut alts)
- = CoCase (libCase env scrut) (libCaseAlts env_alts alts)
+libCase env (Case scrut alts)
+ = Case (libCase env scrut) (libCaseAlts env_alts alts)
where
env_alts = case scrut of
- CoVar scrut_var -> addScrutedVar env scrut_var
+ Var scrut_var -> addScrutedVar env scrut_var
other -> env
\end{code}
~~~~~~~~~~~~~~~~~
\begin{code}
-libCaseAlts env (CoAlgAlts alts deflt)
- = CoAlgAlts (map do_alt alts) (libCaseDeflt env deflt)
+libCaseAlts env (AlgAlts alts deflt)
+ = AlgAlts (map do_alt alts) (libCaseDeflt env deflt)
where
do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
-libCaseAlts env (CoPrimAlts alts deflt)
- = CoPrimAlts (map do_alt alts) (libCaseDeflt env deflt)
+libCaseAlts env (PrimAlts alts deflt)
+ = PrimAlts (map do_alt alts) (libCaseDeflt env deflt)
where
do_alt (lit,rhs) = (lit, libCase env rhs)
-libCaseDeflt env CoNoDefault
- = CoNoDefault
-libCaseDeflt env (CoBindDefault binder rhs)
- = CoBindDefault binder (libCase (addBinders env [binder]) rhs)
+libCaseDeflt env NoDefault
+ = NoDefault
+libCaseDeflt env (BindDefault binder rhs)
+ = BindDefault binder (libCase (addBinders env [binder]) rhs)
\end{code}
Atoms and Ids
~~~~~~~~~~~~~
\begin{code}
-libCaseAtoms :: LibCaseEnv -> [PlainCoreAtom] -> [PlainCoreBinding]
+libCaseAtoms :: LibCaseEnv -> [CoreArg] -> [CoreBinding]
libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms]
-libCaseAtom :: LibCaseEnv -> PlainCoreAtom -> [PlainCoreBinding]
-libCaseAtom env (CoVarAtom arg_id) = libCaseId env arg_id
-libCaseAtom env (CoLitAtom lit) = []
+libCaseAtom :: LibCaseEnv -> CoreArg -> [CoreBinding]
+libCaseAtom env (VarArg arg_id) = libCaseId env arg_id
+libCaseAtom env (LitArg lit) = []
-libCaseId :: LibCaseEnv -> Id -> [PlainCoreBinding]
+libCaseId :: LibCaseEnv -> Id -> [CoreBinding]
libCaseId env v
| maybeToBool maybe_rec_bind && -- It's a use of a recursive thing
there_are_free_scruts -- with free vars scrutinised in RHS
= []
where
- maybe_rec_bind :: Maybe PlainCoreBinding -- The binding of the recursive thingy
+ maybe_rec_bind :: Maybe CoreBinding -- The binding of the recursive thingy
maybe_rec_bind = lookupRecId env v
Just the_bind = maybe_rec_bind
rec_id_level = lookupLevel env v
there_are_free_scruts = freeScruts env rec_id_level
-\end{code}
+\end{code}
where
lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl)
-addRecBinds :: LibCaseEnv -> [(Id,PlainCoreExpr)] -> LibCaseEnv
+addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs
= LibCaseEnv bomb lvl' lvl_env' rec_env' scruts
where
lvl' = lvl + 1
lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
- rec_env' = growIdEnvList rec_env [(binder, CoRec pairs) | (binder,_) <- pairs]
+ rec_env' = growIdEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
-addScrutedVar :: LibCaseEnv
+addScrutedVar :: LibCaseEnv
-> Id -- This Id is being scrutinised by a case expression
- -> LibCaseEnv
+ -> LibCaseEnv
addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var
| bind_lvl < lvl
= LibCaseEnv bomb lvl lvl_env rec_env scruts'
-- Add to scruts iff the scrut_var is being scrutinised at
- -- a deeper level than its defn
+ -- a deeper level than its defn
| otherwise = env
where
Nothing -> --false: ASSERT(toplevelishId scrut_var)
topLevel
-lookupRecId :: LibCaseEnv -> Id -> Maybe PlainCoreBinding
+lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
#ifndef DEBUG
= lookupIdEnv rec_env id
Nothing -> ASSERT(toplevelishId id)
topLevel
-freeScruts :: LibCaseEnv
+freeScruts :: LibCaseEnv
-> LibCaseLevel -- Level of the recursive Id
-> Bool -- True <=> there is an enclosing case of a variable
-- bound outside (ie level <=) the recursive Id.
= not (null free_scruts)
where
free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl]
-\end{code}
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface MagicUFs where
-import BasicLit(BasicLit)
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import Maybes(Labda)
-import PlainCore(PlainCoreArg(..), PlainCoreAtom(..), PlainCoreExpr(..))
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount, SmplM(..), TickType)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-data CoreArg a
-data CoreAtom a
-data CoreExpr a b
-data Id
-data Labda a
-data MagicUnfoldingFun
-type PlainCoreArg = CoreArg Id
-type PlainCoreAtom = CoreAtom Id
-type PlainCoreExpr = CoreExpr Id Id
-data SimplEnv
-data SimplCount
-type SmplM a = SplitUniqSupply -> SimplCount -> (a, SimplCount)
-data TickType
-data SplitUniqSupply
-data UniType
-applyMagicUnfoldingFun :: MagicUnfoldingFun -> SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)
-mkMagicUnfoldingFun :: _PackedString -> MagicUnfoldingFun
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[MagicUFs]{Magic unfoldings that the simplifier knows about}
#include "HsVersions.h"
module MagicUFs (
- MagicUnfoldingFun, -- absolutely abstract
-
- mkMagicUnfoldingFun,
- applyMagicUnfoldingFun,
-
- CoreArg, PlainCoreArg(..), CoreAtom, PlainCoreAtom(..),
- CoreExpr, PlainCoreExpr(..), Id, Maybe, SimplEnv,
- SplitUniqSupply, TickType, UniType,
- SmplM(..), SimplCount
+ MagicUnfoldingFun, -- absolutely abstract
+
+ mkMagicUnfoldingFun,
+ applyMagicUnfoldingFun
) where
-IMPORT_Trace -- ToDo: not sure why this is being used
-
-import AbsPrel ( foldlId, foldrId, buildId, augmentId,
- nilDataCon, consDataCon, mkListTy, mkFunTy,
- unpackCStringAppendId, unpackCStringFoldrId,
- appendId
- )
-import AbsUniType ( splitTypeWithDictsAsArgs, TyVarTemplate )
-import BasicLit ( BasicLit(..) )
-import CmdLineOpts ( SimplifierSwitch(..), switchIsOn, SwitchResult )
-import Id
-import IdInfo
-import Maybes ( Maybe(..), maybeToBool )
-import Outputable
-import PlainCore
-import Pretty
-import SimplEnv
-import SimplMonad
-import TaggedCore
-import Util
+import Ubiq{-uitous-}
+
+import CoreSyn
+import PrelInfo ( mkListTy )
+import SimplEnv ( SimplEnv )
+import SimplMonad ( SmplM(..), SimplCount )
+import Type ( mkFunTys )
+import Unique ( Unique{-instances-} )
+import Util ( assoc, zipWith3Equal, panic )
\end{code}
%************************************************************************
\begin{code}
data MagicUnfoldingFun
= MUF ( SimplEnv -- state of play in simplifier...
- -- (note: we can get simplifier switches
- -- from the SimplEnv)
- -> [PlainCoreArg] -- arguments
- -> SmplM (Maybe PlainCoreExpr))
- -- Just result, or Nothing
+ -- (note: we can get simplifier switches
+ -- from the SimplEnv)
+ -> [CoreArg] -- arguments
+ -> SmplM (Maybe CoreExpr))
+ -- Just result, or Nothing
\end{code}
-Give us a string tag, we'll give you back the corresponding MUF.
+Give us a value's @Unique@, we'll give you back the corresponding MUF.
\begin{code}
-mkMagicUnfoldingFun :: FAST_STRING -> MagicUnfoldingFun
+mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
mkMagicUnfoldingFun tag
- = assoc ("mkMagicUnfoldingFun:" ++ _UNPK_ tag) magic_UFs_table tag
+ = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
+
+magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
\end{code}
Give us an MUF and stuff to apply it to, and we'll give you back the
answer.
\begin{code}
applyMagicUnfoldingFun
- :: MagicUnfoldingFun
- -> SimplEnv
- -> [PlainCoreArg]
- -> SmplM (Maybe PlainCoreExpr)
+ :: MagicUnfoldingFun
+ -> SimplEnv
+ -> [CoreArg]
+ -> SmplM (Maybe CoreExpr)
applyMagicUnfoldingFun (MUF fun) env args = fun env args
\end{code}
%************************************************************************
\begin{code}
+{- LATER:
+
magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
magic_UFs_table
-- First build, the way we express our lists.
build_fun :: SimplEnv
- -> [PlainCoreArg]
- -> SmplM (Maybe PlainCoreExpr)
-build_fun env [TypeArg ty,ValArg (CoVarAtom e)]
+ -> [CoreArg]
+ -> SmplM (Maybe CoreExpr)
+build_fun env [TypeArg ty,ValArg (VarArg e)]
| switchIsSet env SimplDoInlineFoldrBuild =
- let
- tyL = mkListTy ty
- ourCons = mkCoTyApp (CoVar consDataCon) ty
- ourNil = mkCoTyApp (CoVar nilDataCon) ty
- in
- newIds [ ty `mkFunTy` (tyL `mkFunTy` tyL),
- tyL ] `thenSmpl` \ [c,n] ->
- returnSmpl(Just (CoLet (CoNonRec c ourCons)
- (CoLet (CoNonRec n ourNil)
- (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) (CoVarAtom n)))))
+ let
+ tyL = mkListTy ty
+ ourCons = CoTyApp (Var consDataCon) ty
+ ourNil = CoTyApp (Var nilDataCon) ty
+ in
+ newIds [ mkFunTys [ty, tyL] tyL, tyL ] `thenSmpl` \ [c,n] ->
+ returnSmpl(Just (Let (NonRec c ourCons)
+ (Let (NonRec n ourNil)
+ (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))))
-- ToDo: add `build' without an argument instance.
-- This is strange, because of g's type.
-build_fun env _ =
+build_fun env _ =
ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
returnSmpl Nothing
\end{code}
\begin{code}
augment_fun :: SimplEnv
- -> [PlainCoreArg]
- -> SmplM (Maybe PlainCoreExpr)
+ -> [CoreArg]
+ -> SmplM (Maybe CoreExpr)
-augment_fun env [TypeArg ty,ValArg (CoVarAtom e),ValArg nil]
+augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
| switchIsSet env SimplDoInlineFoldrBuild =
- let
- tyL = mkListTy ty
- ourCons = mkCoTyApp (CoVar consDataCon) ty
- in
- newId (ty `mkFunTy` (tyL `mkFunTy` tyL)) `thenSmpl` \ c ->
- returnSmpl (Just (CoLet (CoNonRec c ourCons)
- (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) nil)))
+ let
+ tyL = mkListTy ty
+ ourCons = CoTyApp (Var consDataCon) ty
+ in
+ newId (mkFunTys [ty, tyL] tyL) `thenSmpl` \ c ->
+ returnSmpl (Just (Let (NonRec c ourCons)
+ (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil)))
-- ToDo: add `build' without an argument instance.
-- This is strange, because of g's type.
-augment_fun env _ =
+augment_fun env _ =
ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
returnSmpl Nothing
\end{code}
\begin{code}
foldr_fun :: SimplEnv
- -> [PlainCoreArg]
- -> SmplM (Maybe PlainCoreExpr)
+ -> [CoreArg]
+ -> SmplM (Maybe CoreExpr)
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
| do_fb_red && isConsFun env arg_k && isNilForm env arg_z
-- cf. foldr (:) [] (build g) == g (:) []
-- with foldr (:) [] (build g) == build g
-- after unfolding build, they are the same thing.
- tick Foldr_Cons_Nil `thenSmpl_`
+ tick Foldr_Cons_Nil `thenSmpl_`
newId (mkListTy ty1) `thenSmpl` \ x ->
- returnSmpl({-trace "foldr (:) []"-} (Just (applyToArgs (CoLam [x] (CoVar x)) rest_args)))
+ returnSmpl({-trace "foldr (:) []"-} (Just (mkGenApp (Lam x (Var x)) rest_args)))
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
= -- foldr f z [] = z
-- again another short cut, helps with unroling of constant lists
tick Foldr_Nil `thenSmpl_`
- returnSmpl (Just (atomToExpr arg_z))
+ returnSmpl (Just (argToExpr arg_z))
- | do_fb_red && arg_list_isBuildForm
+ | do_fb_red && arg_list_isBuildForm
= -- foldr k z (build g) ==> g k z
-- this next line *is* the foldr/build rule proper.
tick FoldrBuild `thenSmpl_`
- returnSmpl (Just (applyToArgs (CoVar g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
+ returnSmpl (Just (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
- | do_fb_red && arg_list_isAugmentForm
+ | do_fb_red && arg_list_isAugmentForm
= -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
-- this next line *is* the foldr/augment rule proper.
tick FoldrAugment `thenSmpl_`
newId ty2 `thenSmpl` \ v ->
- returnSmpl (Just
- (CoLet (CoNonRec v (applyToArgs (CoVar foldrId)
+ returnSmpl (Just
+ (Let (NonRec v (mkGenApp (Var foldrId)
[TypeArg ty1,TypeArg ty2,
ValArg arg_k,
ValArg arg_z,
ValArg h]))
- (applyToArgs (CoVar g') (TypeArg ty2:ValArg arg_k:ValArg (CoVarAtom v):rest_args))))
+ (mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args))))
| do_fb_red && arg_list_isListForm
- = -- foldr k z (a:b:c:rest) =
+ = -- foldr k z (a:b:c:rest) =
-- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
-- NB: 'k' is used just one by foldr, but 'f' is used many
-- times inside the list structure. This means that
-- 'f' needs to be inside a lambda, to make sure the simplifier
-- realises this.
- --
- -- The structure of
+ --
+ -- The structure of
-- f a (f b (f c (foldr f z rest)))
-- in core becomes:
-- let ele_1 = foldr f z rest
-- in f a ele_3
--
tick Foldr_List `thenSmpl_`
- newIds (
- ty1 `mkFunTy` (ty2 `mkFunTy` ty2) :
+ newIds (
+ mkFunTys [ty1, ty2] ty2 :
take (length the_list) (repeat ty2)
) `thenSmpl` \ (f_id:ele_id1:ele_ids) ->
let
- fst_bind = CoNonRec
- ele_id1
- (applyToArgs (CoVar foldrId)
+ fst_bind = NonRec
+ ele_id1
+ (mkGenApp (Var foldrId)
[TypeArg ty1,TypeArg ty2,
- ValArg (CoVarAtom f_id),
+ ValArg (VarArg f_id),
ValArg arg_z,
ValArg the_tl])
- --ToDo: look for a zipWith that checks for the same length of a 3 lists
- rest_binds = zipWith3
- (\ e v e' -> CoNonRec e (mkRhs v e'))
+ rest_binds = zipWith3Equal
+ (\ e v e' -> NonRec e (mkRhs v e'))
ele_ids
(reverse (tail the_list))
(init (ele_id1:ele_ids))
- mkRhs v e = CoApp (CoApp (CoVar f_id) v) (CoVarAtom e)
+ mkRhs v e = App (App (Var f_id) v) (VarArg e)
core_list = foldr
- CoLet
+ Let
(mkRhs (head the_list) (last (ele_id1:ele_ids)))
(fst_bind:rest_binds)
in
- returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
+ returnSmpl (Just (mkGenApp (Lam f_id core_list)
(ValArg arg_k:rest_args)))
- --
+ --
| do_fb_red && arg_list_isStringForm -- ok, its a string!
-- foldr f z "foo" => unpackFoldrPS# f z "foo"#
= tick Str_FoldrStr `thenSmpl_`
- returnSmpl (Just (applyToArgs (CoVar unpackCStringFoldrId)
+ returnSmpl (Just (mkGenApp (Var unpackCStringFoldrId)
(TypeArg ty2:
- ValArg (CoLitAtom (MachStr str_val)):
+ ValArg (LitArg (MachStr str_val)):
ValArg arg_k:
ValArg arg_z:
rest_args)))
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
| doing_inlining && isConsFun env arg_k && not dont_fold_back_append
- = -- foldr (:) z xs = xs ++ z
+ = -- foldr (:) z xs = xs ++ z
tick Foldr_Cons `thenSmpl_`
newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
- returnSmpl (Just (applyToArgs
- (CoLam [z,x] (applyToArgs
- (CoVar appendId) [
- TypeArg ty1,
- ValArg (CoVarAtom x),
- ValArg (CoVarAtom z)]))
- rest_args))
- | doing_inlining && (isInterestingArg env arg_k
+ returnSmpl (Just (mkGenApp
+ (Lam z (Lam x (mkGenApp
+ (Var appendId) [
+ TypeArg ty1,
+ ValArg (VarArg x),
+ ValArg (VarArg z)])))
+ rest_args))
+ | doing_inlining && (isInterestingArg env arg_k
|| isConsFun env arg_k)
- = -- foldr k args =
+ = -- foldr k args =
-- (\ f z xs ->
- -- letrec
+ -- letrec
-- h x = case x of
-- [] -> z
-- (a:b) -> f a (h b)
--
-- tick FoldrInline `thenSmpl_`
newIds [
- ty1, -- a :: t1
- mkListTy ty1, -- b :: [t1]
- ty2, -- v :: t2
- mkListTy ty1, -- x :: t1
- mkListTy ty1 `mkFunTy` ty2,
- -- h :: [t1] -> t2
- ty1 `mkFunTy` (ty2 `mkFunTy` ty2),
- -- f
- ty2, -- z
- mkListTy ty1 -- xs
- ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
- let
- h_rhs = (CoLam [x] (CoCase (CoVar x)
- (CoAlgAlts
- [(nilDataCon,[],atomToExpr (CoVarAtom z)),
- (consDataCon,[a,b],body)]
- CoNoDefault)))
- body = CoLet (CoNonRec v (CoApp (CoVar h) (CoVarAtom b)))
- (CoApp (CoApp (atomToExpr (CoVarAtom f))
- (CoVarAtom a))
- (CoVarAtom v))
- in
- returnSmpl (Just
- (applyToArgs
- (CoLam [f,z,xs]
- (CoLet (CoRec [(h,h_rhs)])
- (CoApp (CoVar h) (CoVarAtom xs))))
- (ValArg arg_k:rest_args)))
+ ty1, -- a :: t1
+ mkListTy ty1, -- b :: [t1]
+ ty2, -- v :: t2
+ mkListTy ty1, -- x :: t1
+ mkFunTys [mkListTy ty1] ty2,
+ -- h :: [t1] -> t2
+ mkFunTys [ty1, ty2] ty2,
+ -- f
+ ty2, -- z
+ mkListTy ty1 -- xs
+ ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
+ let
+ h_rhs = (Lam x (Case (Var x)
+ (AlgAlts
+ [(nilDataCon,[],argToExpr (VarArg z)),
+ (consDataCon,[a,b],body)]
+ NoDefault)))
+ body = Let (NonRec v (App (Var h) (VarArg b)))
+ (App (App (argToExpr (VarArg f))
+ (VarArg a))
+ (VarArg v))
+ in
+ returnSmpl (Just
+ (mkGenApp
+ (Lam f (Lam z (Lam xs
+ (Let (Rec [(h,h_rhs)])
+ (App (Var h) (VarArg xs))))))
+ (ValArg arg_k:rest_args)))
where
- doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
- dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
+ doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
+ dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
foldr_fun _ _ = returnSmpl Nothing
-isConsFun :: SimplEnv -> PlainCoreAtom -> Bool
-isConsFun env (CoVarAtom v) =
+isConsFun :: SimplEnv -> CoreArg -> Bool
+isConsFun env (VarArg v) =
case lookupUnfolding env v of
- GeneralForm _ _ (CoLam [(x,_),(y,_)]
- (CoCon con tys [CoVarAtom x',CoVarAtom y'])) _
- | con == consDataCon && x==x' && y==y'
- -> ASSERT ( length tys == 1 ) True
- _ -> False
+ 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 -> PlainCoreAtom -> Bool
-isNilForm env (CoVarAtom v) =
+isNilForm :: SimplEnv -> CoreArg -> Bool
+isNilForm env (VarArg v) =
case lookupUnfolding env v of
- GeneralForm _ _ (CoTyApp (CoVar id) _) _
- | id == nilDataCon -> True
- ConstructorForm id _ _
- | id == nilDataCon -> True
- LiteralForm (NoRepStr s) | _NULL_ s -> True
- _ -> False
+ GenForm _ _ (CoTyApp (Var id) _) _
+ | id == nilDataCon -> True
+ ConForm id _ _
+ | id == nilDataCon -> True
+ LitForm (NoRepStr s) | _NULL_ s -> True
+ _ -> False
isNilForm env _ = False
-getBuildForm :: SimplEnv -> PlainCoreAtom -> Maybe Id
-getBuildForm env (CoVarAtom v) =
+getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
+getBuildForm env (VarArg v) =
case lookupUnfolding env v of
- GeneralForm False _ _ _ -> Nothing
+ GenForm False _ _ _ -> Nothing
-- not allowed to inline :-(
- GeneralForm _ _ (CoApp (CoTyApp (CoVar bld) _) (CoVarAtom g)) _
- | bld == buildId -> Just g
- GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _)
- (CoVarAtom g)) h) _
- | bld == augmentId && isNilForm env h -> Just g
- _ -> Nothing
+ GenForm _ _ (App (CoTyApp (Var bld) _) (VarArg g)) _
+ | bld == buildId -> Just g
+ GenForm _ _ (App (App (CoTyApp (Var bld) _)
+ (VarArg g)) h) _
+ | bld == augmentId && isNilForm env h -> Just g
+ _ -> Nothing
getBuildForm env _ = Nothing
-getAugmentForm :: SimplEnv -> PlainCoreAtom -> Maybe (Id,PlainCoreAtom)
-getAugmentForm env (CoVarAtom v) =
+getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
+getAugmentForm env (VarArg v) =
case lookupUnfolding env v of
- GeneralForm False _ _ _ -> Nothing
+ GenForm False _ _ _ -> Nothing
-- not allowed to inline :-(
- GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _)
- (CoVarAtom g)) h) _
- | bld == augmentId -> Just (g,h)
- _ -> Nothing
+ GenForm _ _ (App (App (CoTyApp (Var bld) _)
+ (VarArg g)) h) _
+ | bld == augmentId -> Just (g,h)
+ _ -> Nothing
getAugmentForm env _ = Nothing
-getStringForm :: SimplEnv -> PlainCoreAtom -> Maybe FAST_STRING
-getStringForm env (CoLitAtom (NoRepStr str)) = Just str
+getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
+getStringForm env (LitArg (NoRepStr str)) = Just str
getStringForm env _ = Nothing
{-
-getAppendForm :: SimplEnv -> PlainCoreAtom -> Maybe (CoreAtom Id,CoreAtom Id)
-getAppendForm env (CoVarAtom v) =
+getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
+getAppendForm env (VarArg v) =
case lookupUnfolding env v of
- GeneralForm False _ _ _ -> Nothing -- not allowed to inline :-(
- GeneralForm _ _ (CoApp (CoApp (CoApp (CoTyApp (CoTyApp (CoVar fld) _) _) con) ys) xs) _
- | fld == foldrId && isConsFun env con -> Just (xs,ys)
- _ -> Nothing
+ GenForm False _ _ _ -> Nothing -- not allowed to inline :-(
+ GenForm _ _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
+ | fld == foldrId && isConsFun env con -> Just (xs,ys)
+ _ -> Nothing
getAppendForm env _ = Nothing
-}
--
getListForm
- :: SimplEnv
- -> PlainCoreAtom
- -> Maybe ([PlainCoreAtom],PlainCoreAtom)
-getListForm env (CoVarAtom v) =
+ :: SimplEnv
+ -> CoreArg
+ -> Maybe ([CoreArg],CoreArg)
+getListForm env (VarArg v) =
case lookupUnfolding env v of
- ConstructorForm id _ [head,tail]
- | id == consDataCon ->
+ ConForm id _ [head,tail]
+ | id == consDataCon ->
case getListForm env tail of
Nothing -> Just ([head],tail)
Just (lst,new_tail) -> Just (head:lst,new_tail)
_ -> Nothing
getListForm env _ = Nothing
-isInterestingArg :: SimplEnv -> PlainCoreAtom -> Bool
-isInterestingArg env (CoVarAtom v) =
+isInterestingArg :: SimplEnv -> CoreArg -> Bool
+isInterestingArg env (VarArg v) =
case lookupUnfolding env v of
- GeneralForm False _ _ UnfoldNever -> False
- GeneralForm _ _ exp guide -> True
+ GenForm False _ _ UnfoldNever -> False
+ GenForm _ _ exp guide -> True
_ -> False
isInterestingArg env _ = False
= -- foldl f z [] = z
-- again another short cut, helps with unroling of constant lists
tick Foldl_Nil `thenSmpl_`
- returnSmpl (Just (atomToExpr arg_z))
+ returnSmpl (Just (argToExpr arg_z))
- | do_fb_red && arg_list_isBuildForm
- = -- foldl t1 t2 k z (build t3 g) ==>
- -- let c {- INLINE -} = \ b g' a -> g' (f a b)
+ | do_fb_red && arg_list_isBuildForm
+ = -- foldl t1 t2 k z (build t3 g) ==>
+ -- let c {- INLINE -} = \ b g' a -> g' (f a b)
-- n {- INLINE -} = \ a -> a
-- in g t1 c n z
-- this next line *is* the foldr/build rule proper.
-- c :: t2 -> (t1 -> t1) -> t1 -> t1
-- n :: t1 -> t1
newIds [
- {- pre_c -} ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)),
- {- pre_n -} ty1 `mkFunTy` ty1,
+ {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
+ {- pre_n -} mkFunTys [ty1] ty1,
{- b -} ty2,
- {- g' -} ty1 `mkFunTy` ty1,
+ {- g' -} mkFunTys [ty1] ty1,
{- a -} ty1,
- {- a' -} ty1,
+ {- a' -} ty1,
{- t -} ty1
] `thenSmpl` \ [pre_c,
pre_n,
let
c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
- c_rhs = CoLam [b,g',a]
- (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b)))
- (CoApp (CoVar g') (CoVarAtom t)))
- n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
- n_rhs = CoLam [a'] (CoVar a')
+ c_rhs = Lam b (Lam g' (Lam a
+ (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+ (App (Var g') (VarArg t)))))
+ n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
+ n_rhs = Lam a' (Var a')
in
- returnSmpl (Just (CoLet (CoNonRec c c_rhs) (CoLet (CoNonRec n n_rhs)
- (applyToArgs (CoVar g)
- (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom n)
+ returnSmpl (Just (Let (NonRec c c_rhs) (Let (NonRec n n_rhs)
+ (mkGenApp (Var g)
+ (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
:ValArg arg_z:rest_args)))))
- | do_fb_red && arg_list_isAugmentForm
- = -- foldl t1 t2 k z (augment t3 g h) ==>
- -- let c {- INLINE -} = \ b g' a -> g' (f a b)
+ | do_fb_red && arg_list_isAugmentForm
+ = -- foldl t1 t2 k z (augment t3 g h) ==>
+ -- let c {- INLINE -} = \ b g' a -> g' (f a b)
-- n {- INLINE -} = \ a -> a
-- r {- INLINE -} = foldr t2 (t1 -> t1) c n h
-- in g t1 c r z
-- c :: t2 -> (t1 -> t1) -> t1 -> t1
-- n :: t1 -> t1
newIds [
- {- pre_c -} ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)),
- {- pre_n -} ty1 `mkFunTy` ty1,
- {- pre_r -} ty1 `mkFunTy` ty1,
+ {- pre_c -} mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
+ {- pre_n -} mkFunTys [ty1] ty1,
+ {- pre_r -} mkFunTys [ty1] ty1,
{- b -} ty2,
- {- g_ -} ty1 `mkFunTy` ty1,
+ {- g_ -} mkFunTys [ty1] ty1,
{- a -} ty1,
- {- a' -} ty1,
+ {- a' -} ty1,
{- t -} ty1
] `thenSmpl` \ [pre_c,
pre_n,
let
c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways)
- c_rhs = CoLam [b,g_,a]
- (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b)))
- (CoApp (CoVar g_) (CoVarAtom t)))
- n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
- n_rhs = CoLam [a'] (CoVar a')
- r = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
- r_rhs = applyToArgs (CoVar foldrId)
- [TypeArg ty2,TypeArg (ty1 `mkFunTy` ty1),
- ValArg (CoVarAtom c),
- ValArg (CoVarAtom n),
+ c_rhs = Lam b (Lam g_ (Lam a
+ (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
+ (App (Var g_) (VarArg t)))))
+ n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways)
+ n_rhs = Lam a' (Var a')
+ r = addIdUnfolding pre_r (iWantToBeINLINEd UnfoldAlways)
+ r_rhs = mkGenApp (Var foldrId)
+ [TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
+ ValArg (VarArg c),
+ ValArg (VarArg n),
ValArg h]
in
- returnSmpl (Just (CoLet (CoNonRec c c_rhs)
- (CoLet (CoNonRec n n_rhs)
- (CoLet (CoNonRec r r_rhs)
- (applyToArgs (CoVar g')
- (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom r)
+ returnSmpl (Just (Let (NonRec c c_rhs)
+ (Let (NonRec n n_rhs)
+ (Let (NonRec r r_rhs)
+ (mkGenApp (Var g')
+ (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
:ValArg arg_z:rest_args))))))
| do_fb_red && arg_list_isListForm
- = -- foldl k z (a:b:c:rest) =
+ = -- foldl k z (a:b:c:rest) =
-- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
-- NB: 'k' is used just one by foldr, but 'f' is used many
-- times inside the list structure. This means that
-- 'f' needs to be inside a lambda, to make sure the simplifier
-- realises this.
- --
- -- The structure of
+ --
+ -- The structure of
-- foldl f (f (f (f z a) b) c) rest
-- f a (f b (f c (foldr f z rest)))
-- in core becomes:
-- in foldl f ele_3 rest
--
tick Foldl_List `thenSmpl_`
- newIds (
- ty1 `mkFunTy` (ty2 `mkFunTy` ty1) :
+ newIds (
+ mkFunTys [ty1, ty2] ty1 :
take (length the_list) (repeat ty1)
) `thenSmpl` \ (f_id:ele_ids) ->
let
- --ToDo: look for a zipWith that checks for the same length of a 3 lists
- rest_binds = zipWith3
- (\ e v e' -> CoNonRec e (mkRhs v e'))
+ rest_binds = zipWith3Equal
+ (\ e v e' -> NonRec e (mkRhs v e'))
ele_ids -- :: [Id]
- the_list -- :: [PlainCoreAtom]
- (init (arg_z:map CoVarAtom ele_ids)) -- :: [PlainCoreAtom]
- mkRhs v e = CoApp (CoApp (CoVar f_id) e) v
+ the_list -- :: [CoreArg]
+ (init (arg_z:map VarArg ele_ids)) -- :: [CoreArg]
+ mkRhs v e = App (App (Var f_id) e) v
- last_bind = applyToArgs (CoVar foldlId)
+ last_bind = mkGenApp (Var foldlId)
[TypeArg ty1,TypeArg ty2,
- ValArg (CoVarAtom f_id),
- ValArg (CoVarAtom (last ele_ids)),
+ ValArg (VarArg f_id),
+ ValArg (VarArg (last ele_ids)),
ValArg the_tl]
core_list = foldr
- CoLet
+ Let
last_bind
rest_binds
in
- returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
+ returnSmpl (Just (mkGenApp (Lam f_id core_list)
(ValArg arg_k:rest_args)))
where
-}
foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
- | doing_inlining && (isInterestingArg env arg_k
+ | doing_inlining && (isInterestingArg env arg_k
|| isConsFun env arg_k)
- = -- foldl k args =
+ = -- foldl k args =
-- (\ f z xs ->
- -- letrec
+ -- letrec
-- h x r = case x of
-- [] -> r
-- (a:b) -> h b (f r a)
--
-- tick FoldrInline `thenSmpl_`
newIds [
- ty2, -- a :: t1
- mkListTy ty2, -- b :: [t1]
- ty1, -- v :: t2
- mkListTy ty2, -- x :: t1
- mkListTy ty2 `mkFunTy` (ty1 `mkFunTy` ty1),
- -- h :: [t2] -> t1 -> t1
- ty1 `mkFunTy` (ty2 `mkFunTy` ty1),
- -- f
- ty1, -- z
- mkListTy ty2, -- xs
+ ty2, -- a :: t1
+ mkListTy ty2, -- b :: [t1]
+ ty1, -- v :: t2
+ mkListTy ty2, -- x :: t1
+ mkFunTys [mkListTy ty2, ty1] ty1,
+ -- h :: [t2] -> t1 -> t1
+ mkFunTys [ty1, ty2] ty1,
+ -- f
+ ty1, -- z
+ mkListTy ty2, -- xs
ty1 -- r
- ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
- let
- h_rhs = (CoLam [x,r] (CoCase (CoVar x)
- (CoAlgAlts
- [(nilDataCon,[],atomToExpr (CoVarAtom r)),
- (consDataCon,[a,b],body)]
- CoNoDefault)))
- body = CoLet (CoNonRec v (CoApp (CoApp (CoVar f) (CoVarAtom r))
- (CoVarAtom a)))
- (CoApp (CoApp (atomToExpr (CoVarAtom h))
- (CoVarAtom b))
- (CoVarAtom v))
- in
- returnSmpl (Just
- (applyToArgs
- (CoLam [f,z,xs]
- (CoLet (CoRec [(h,h_rhs)])
- (CoApp (CoApp (CoVar h) (CoVarAtom xs))
- (CoVarAtom z))))
- (ValArg arg_k:rest_args)))
+ ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
+ let
+ h_rhs = (Lam x (Lam r (Case (Var x))
+ (AlgAlts
+ [(nilDataCon,[],argToExpr (VarArg r)),
+ (consDataCon,[a,b],body)]
+ NoDefault)))
+ body = Let (NonRec v (App (App (Var f) (VarArg r))
+ (VarArg a)))
+ (App (App (argToExpr (VarArg h))
+ (VarArg b))
+ (VarArg v))
+ in
+ returnSmpl (Just
+ (mkGenApp
+ (Lam f (Lam z (Lam xs
+ (Let (Rec [(h,h_rhs)])
+ (App (App (Var h) (VarArg xs))
+ (VarArg z))))))
+ (ValArg arg_k:rest_args)))
where
- doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
+ doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
foldl_fun env _ = returnSmpl Nothing
\end{code}
\begin{code}
--
--- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
+-- Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
--
unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
| switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
= tick Str_UnpackCons `thenSmpl_`
- returnSmpl (Just (applyToArgs (CoVar unpackCStringAppendId)
+ returnSmpl (Just (mkGenApp (Var unpackCStringAppendId)
[ValArg str,
ValArg arg_z]))
unpack_foldr_fun env _ = returnSmpl Nothing
-unpack_append_fun env
- [ValArg (CoLitAtom (MachStr str_val)),ValArg arg_z]
+unpack_append_fun env
+ [ValArg (LitArg (MachStr str_val)),ValArg arg_z]
| switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
= tick Str_UnpackNil `thenSmpl_`
- returnSmpl (Just (CoLit (NoRepStr str_val)))
+ returnSmpl (Just (Lit (NoRepStr str_val)))
unpack_append_fun env _ = returnSmpl Nothing
+-}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface NewOccurAnal where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..))
-import PrimOps(PrimOp)
-import TaggedCore(SimplifiableCoreBinding(..), SimplifiableCoreExpr(..))
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data BinderInfo
-data GlobalSwitch
-data CoreBinding a b
-data CoreExpr a b
-data Id
-type PlainCoreExpr = CoreExpr Id Id
-type PlainCoreProgram = [CoreBinding Id Id]
-type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id
-type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-newOccurAnalyseBinds :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> (SimplifierSwitch -> Bool) -> [CoreBinding (Id, BinderInfo) Id]
-newOccurAnalyseExpr :: UniqFM Id -> CoreExpr Id Id -> (UniqFM BinderInfo, CoreExpr (Id, BinderInfo) Id)
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-%************************************************************************
-%* *
-\section[NewOccurAnal]{The *New* Occurrence analysis pass}
-%* *
-%************************************************************************
-
-The occurrence analyser analyses the way in which variables are used
-in their scope, and pins that information on the binder. It does {\em
-not} take any strategic decisions about what to do as a result (eg
-discard binding, inline binding etc). That's the job of the
-simplifier.
-
-The occurrence analyser {\em simply} records usage information. That is,
-it pins on each binder info on how that binder occurs in its scope.
-
-Any uses within the RHS of a let(rec) binding for a variable which is
-itself unused are ignored. For example:
-@
- let x = ...
- y = ...x...
- in
- x+1
-@
-Here, y is unused, so x will be marked as appearing just once.
-
-An exported Id gets tagged as ManyOcc.
-
-IT MUST OBSERVE SCOPING: CANNOT assume unique binders.
-
-Lambdas
-~~~~~~~
-The occurrence analyser marks each binder in a lambda the same way.
-Thus:
- \ x y -> f y x
-will have both x and y marked as single occurrence, and *not* dangerous-to-dup.
-Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup,
-but the simplifer very carefully takes care of this special case.
-(See the CoLam case in simplExpr.)
-
-Why? Because typically applications are saturated, in which case x is *not*
-dangerous-to-dup.
-
-Things to muse upon
-~~~~~~~~~~~~~~~~~~~
-
-There *is* a reason not to substitute for
-variables applied to types: it can undo the effect of floating
-Consider:
-\begin{verbatim}
- c = /\a -> e
- f = /\b -> let d = c b
- in \ x::b -> ...
-\end{verbatim}
-Here, inlining c would be a Bad Idea.
-
-At present I've set it up so that the "inside-lambda" flag sets set On
-for type-lambdas too, which effectively prevents such substitutions.
-I don't *think* it disables any interesting ones either.
-
-Oh yes it does.
-Consider
-
- let { (u6.sAMi, <1,0>) = (_build s141374) ua.sALY } in
- let {
- (ua.sAMj, <1,0>) =
- /\ s141380 -> \ (u5.sAM1, <2,0>) (u6.sAMl, <2,0>) ->
- let {
- (u9.sAM7, <2,0>) =
- \ (u7.sAM2, <3,0>) ->
- let { (u8.sAM3, <3,0>) = f.sALV u7.sAM2
- } in u5.sAM1 u8.sAM3
- } in ((foldr s141374) s141380) u9.sAM7 u6.sAMl u6.sAMi
- } in (_build s141376) ua.sAMj]
-
-I want to `inline' u6.sAMi, via the foldr/build rule,
-but I cant. So I need to inline through /\. I only do it when
-I've got a `linear' stack, ie actually real arguments still to apply.
-
-\begin{code}
-#include "HsVersions.h"
-
-module NewOccurAnal (
- newOccurAnalyseBinds, newOccurAnalyseExpr,
-
- -- and to make the interface self-sufficient...
- CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
- PlainCoreProgram(..), PlainCoreExpr(..),
- SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
- ) where
-
-IMPORT_Trace
-import Outputable -- ToDo: rm; debugging
-import Pretty
-
-import PlainCore -- the stuff we read...
-import TaggedCore -- ... and produce Simplifiable*
-
-import AbsUniType
-import BinderInfo
-import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) )
-import Digraph ( stronglyConnComp )
-import Id ( eqId, idWantsToBeINLINEd, isConstMethodId_maybe,
- isSpecPragmaId_maybe, getIdArgUsageInfo,
- SpecInfo
- )
-import IdInfo -- ( ArgUsage(..), ArgUsageInfo, OptIdInfo(..), getArgUsage)
-import IdEnv
-import Maybes
-import UniqSet
-import Util
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[OccurAnal-types]{Data types}
-%* *
-%************************************************************************
-
-\begin{code}
-data OccEnv = OccEnv
- Bool -- Keep-unused-bindings flag
- -- False <=> OK to chuck away binding
- -- and ignore occurrences within it
- Bool -- Keep-spec-pragma-ids flag
- -- False <=> OK to chuck away spec pragma bindings
- -- and ignore occurrences within it
- Bool -- Keep-conjurable flag
- -- False <=> OK to throw away *dead*
- -- "conjurable" Ids; at the moment, that
- -- *only* means constant methods, which
- -- are top-level. A use of a "conjurable"
- -- Id may appear out of thin air -- e.g.,
- -- specialiser conjuring up refs to const
- -- methods.
- Bool -- IgnoreINLINEPragma flag
- -- False <=> OK to use INLINEPragma information
- -- True <=> ignore INLINEPragma information
- (UniqSet Id) -- Candidates
-
-addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
- = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
-
-addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
- = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
-
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
-
-ignoreINLINEPragma :: OccEnv -> Bool
-ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
-
-keepUnusedBinding :: OccEnv -> Id -> Bool
-keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
- = keep_dead || (keep_spec && is_spec)
- where
- is_spec = maybeToBool (isSpecPragmaId_maybe binder)
-
-keepBecauseConjurable :: OccEnv -> Id -> Bool
-keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
- = keep_conjurable && is_conjurable
- where
- is_conjurable = maybeToBool (isConstMethodId_maybe binder)
-
-type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
-
-combineUsageDetails, combineAltsUsageDetails
- :: UsageDetails -> UsageDetails -> UsageDetails
-
-combineUsageDetails usage1 usage2
- = --BSCC("combineUsages")
- combineIdEnvs combineBinderInfo usage1 usage2
- --ESCC
-
-combineAltsUsageDetails usage1 usage2
- = --BSCC("combineUsages")
- combineIdEnvs combineAltsBinderInfo usage1 usage2
- --ESCC
-
-addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
-addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
- -- ToDo: make this more efficient
-
-emptyDetails = (nullIdEnv :: UsageDetails)
-
-unitDetails id info = (unitIdEnv id info :: UsageDetails)
-
-tagBinders :: UsageDetails -- Of scope
- -> [Id] -- Binders
- -> (UsageDetails, -- Details with binders removed
- [(Id,BinderInfo)]) -- Tagged binders
-
-tagBinders usage binders
- = (usage `delManyFromIdEnv` binders,
- [(binder, usage_of usage binder) | binder <- binders]
- )
-
-tagBinder :: UsageDetails -- Of scope
- -> Id -- Binders
- -> (UsageDetails, -- Details with binders removed
- (Id,BinderInfo)) -- Tagged binders
-
-tagBinder usage binder
- = (usage `delOneFromIdEnv` binder,
- (binder, usage_of usage binder)
- )
-
-usage_of usage binder
- | isExported binder = ManyOcc 0 -- Exported things count as many
- | otherwise
- = case lookupIdEnv usage binder of
- Nothing -> DeadCode
- Just info -> info
-
-fixStkToZero :: Id -> UsageDetails -> UsageDetails
-fixStkToZero id env = modifyIdEnv env setBinderInfoArityToZero id
-
-isNeeded env usage binder
- = case usage_of usage binder of
- DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
- other -> True
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[OccurAnal-main]{Counting occurrences: main function}
-%* *
-%************************************************************************
-
-Here's the externally-callable interface:
-
-\begin{code}
-newOccurAnalyseBinds
- :: [PlainCoreBinding] -- input
- -> (GlobalSwitch -> Bool)
- -> (SimplifierSwitch -> Bool)
- -> [SimplifiableCoreBinding] -- output
-
-newOccurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
- | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
- | otherwise = binds'
- where
- (_, binds') = do initial_env binds
-
- initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
- (simplifier_sw_chkr KeepSpecPragmaIds)
- (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
- (simplifier_sw_chkr IgnoreINLINEPragma)
- emptyUniqSet
-
- do env [] = (emptyDetails, [])
- do env (bind:binds)
- = (final_usage, new_binds ++ the_rest)
- where
- new_env = env `addNewCands` (bindersOf bind)
- (binds_usage, the_rest) = do new_env binds
- (final_usage, new_binds) = --BSCC("occAnalBind1")
- occAnalBind env bind binds_usage
- --ESCC
-\end{code}
-
-\begin{code}
-newOccurAnalyseExpr :: UniqSet Id -- Set of interesting free vars
- -> PlainCoreExpr
- -> (IdEnv BinderInfo, -- Occ info for interesting free vars
- SimplifiableCoreExpr)
-
-newOccurAnalyseExpr candidates expr
- = occAnal initial_env initContext expr
- where
- initial_env = OccEnv False {- Drop unused bindings -}
- False {- Drop SpecPragmaId bindings -}
- True {- Keep conjurable Ids -}
- False {- Do not ignore INLINE Pragma -}
- candidates
-
-newOccurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
-newOccurAnalyseGlobalExpr expr
- = -- Top level expr, so no interesting free vars, and
- -- discard occurence info returned
- expr' where (_, expr') = newOccurAnalyseExpr emptyUniqSet expr
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[OccurAnal-main]{Counting occurrences: main function}
-%* *
-%************************************************************************
-
-Bindings
-~~~~~~~~
-
-\begin{code}
-occAnalBind :: OccEnv
- -> PlainCoreBinding
- -> UsageDetails -- Usage details of scope
- -> (UsageDetails, -- Of the whole let(rec)
- [SimplifiableCoreBinding])
-
-occAnalBind env (CoNonRec binder rhs) body_usage
- | isNeeded env body_usage binder -- It's mentioned in body
- = (final_body_usage `combineUsageDetails` rhs_usage,
- [CoNonRec tagged_binder rhs'])
-
- | otherwise
- = (body_usage, [])
-
- where
- stk = mkContextFromBinderInfo (usage_of body_usage binder)
- (rhs_usage, rhs') = occAnalRhs env binder stk rhs
- (final_body_usage, tagged_binder) = tagBinder body_usage binder
-
-occAnalBind env (CoRec [(binder,rhs)]) body_usage
- | getContextSize after_stk < getContextSize stk && mentions_itself
- -- our pre-condition does not hold!
- -- so, we have to go back, and
- -- *make* of pre-condition hold.
- -- Will, you can leave out this trace
- = {-pprTrace ("after_stk < stk (BAD, BAD, VERY VERY BAD):"
- ++ show (getContextSize after_stk,getContextSize stk)) (ppr PprDebug binder) -}
- (occAnalBind env (CoRec [(binder,rhs)]) (fixStkToZero binder body_usage))
-
- | isNeeded env body_usage binder -- It's mentioned in body
- = --BSCC("occAnalBindC")
- (final_usage, [final_bind])
- --ESCC
-
- | otherwise
- = --BSCC("occAnalBindD")
- (body_usage, [])
- --ESCC
-
- where
- stk = shareContext (mkContextFromBinderInfo (usage_of body_usage binder))
- new_env = env `addNewCand` binder
- (rhs_usage, rhs') = occAnalRhs new_env binder stk rhs
- total_usage = combineUsageDetails body_usage rhs_usage
- (final_usage, tagged_binder) = tagBinder total_usage binder
-
- after_stk = mkContextFromBinderInfo (usage_of rhs_usage binder)
-
- final_bind = if mentions_itself
- then CoRec [(tagged_binder,rhs')]
- else CoNonRec tagged_binder rhs'
-
- mentions_itself = maybeToBool (lookupIdEnv rhs_usage binder)
-\end{code}
-
-Dropping dead code for recursive bindings is done in a very simple way:
-
- the entire set of bindings is dropped if none of its binders are
- mentioned in its body; otherwise none are.
-
-This seems to miss an obvious improvement.
-@
- letrec f = ...g...
- g = ...f...
- in
- ...g...
-
-===>
-
- letrec f = ...g...
- g = ...(...g...)...
- in
- ...g...
-@
-
-Now @f@ is unused. But dependency analysis will sort this out into a
-@letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
-It isn't easy to do a perfect job in one blow. Consider
-
-@
- letrec f = ...g...
- g = ...h...
- h = ...k...
- k = ...m...
- m = ...m...
- in
- ...m...
-@
-
-
-\begin{code}
-occAnalBind env (CoRec pairs) body_usage
- = foldr do_final_bind (body_usage, []) sccs
- where
-
- (binders, rhss) = unzip pairs
- new_env = env `addNewCands` binders
-
- analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
- analysed_pairs = [(id, occAnalRhs new_env id initContext rhs) | (id,rhs) <- pairs]
-
- lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
- lookup id = assoc "occAnalBind:lookup" analysed_pairs id
-
-
- ---- stuff for dependency analysis of binds -------------------------------
-
- edges :: [(Id,Id)] -- (a,b) means a mentions b
- edges = concat [ edges_from binder rhs_usage
- | (binder, (rhs_usage, _)) <- analysed_pairs]
-
- edges_from :: Id -> UsageDetails -> [(Id,Id)]
- edges_from id its_rhs_usage
- = [(id,mentioned) | mentioned <- binders,
- maybeToBool (lookupIdEnv its_rhs_usage mentioned)
- ]
-
- sccs :: [[Id]]
- sccs = case binders of
- [_] -> [binders] -- Singleton; no need to analyse
- other -> stronglyConnComp eqId edges binders
-
- ---- stuff to "re-constitute" bindings from dependency-analysis info ------
-
- do_final_bind sCC@[binder] (body_usage, binds_so_far)
- | isNeeded env body_usage binder
- = (combined_usage, new_bind:binds_so_far)
-
- | otherwise -- Dead
- = (body_usage, binds_so_far)
- where
- total_usage = combineUsageDetails body_usage rhs_usage
- (rhs_usage, rhs') = lookup binder
- (combined_usage, tagged_binder) = tagBinder total_usage binder
-
- new_bind
- | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
- | otherwise = CoNonRec tagged_binder rhs'
- where
- mentions_itself binder usage
- = maybeToBool (lookupIdEnv usage binder)
-
- do_final_bind sCC (body_usage, binds_so_far)
- | any (isNeeded env body_usage) sCC
- = (combined_usage, new_bind:binds_so_far)
-
- | otherwise -- Dead
- = (body_usage, binds_so_far)
- where
- (rhs_usages, rhss') = unzip (map lookup sCC)
- total_usage = foldr combineUsageDetails body_usage rhs_usages
- (combined_usage, tagged_binders) = tagBinders total_usage sCC
-
- new_bind = CoRec (tagged_binders `zip` rhss')
-\end{code}
-
-@occAnalRhs@ deals with the question of bindings where the Id is marked
-by an INLINE pragma. For these we record that anything which occurs
-in its RHS occurs many times. This pessimistically assumes that ths
-inlined binder also occurs many times in its scope, but if it doesn't
-we'll catch it next time round. At worst this costs an extra simplifier pass.
-ToDo: try using the occurrence info for the inline'd binder.
-
-\begin{code}
-occAnalRhs :: OccEnv
- -> Id -- Binder
- -> Context -- Stack Style Context
- -> PlainCoreExpr -- Rhs
- -> (UsageDetails, SimplifiableCoreExpr)
-
-occAnalRhs env id stk rhs
- | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
- = (mapIdEnv markMany rhs_usage, rhs')
-
- | otherwise
- = (rhs_usage, rhs')
-
- where
- (rhs_usage, rhs') = occAnal env stk rhs
-\end{code}
-
-Expressions
-~~~~~~~~~~~
-\begin{code}
-occAnal :: OccEnv
- -> Context
- -> PlainCoreExpr
- -> (UsageDetails, -- Gives info only about the "interesting" Ids
- SimplifiableCoreExpr)
-
-occAnal env stk (CoVar v)
- | isCandidate env v
- = (unitIdEnv v (funOccurrence (getContextSize stk)), CoVar v)
-
- | otherwise
- = (emptyDetails, CoVar v)
-
-occAnal env _ (CoLit lit) = (emptyDetails, CoLit lit)
--- PERHAPS ASSERT THAT STACK == 0 ?
-occAnal env _ (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
-occAnal env _ (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
-
-occAnal env stk (CoSCC lbl body)
- = (mapIdEnv markInsideSCC usage, CoSCC lbl body')
- where
- (usage, body') = occAnal env initContext body
-
-occAnal env stk (CoApp fun arg)
- = occAnalApp env (incContext stk) [ValArg arg] fun
-occAnal env stk (CoTyApp fun arg)
- = occAnalApp env stk [TypeArg arg] fun
-{-
-occAnal env (CoApp fun arg)
- = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
- where
- (fun_usage, fun') = occAnal env fun
- arg_usage = occAnalAtom env arg
-
-occAnal env (CoTyApp fun ty)
- = (fun_usage, CoTyApp fun' ty)
- where
- (fun_usage, fun') = occAnal env fun
--}
-occAnal env stk (CoLam binders body) | isLinContext stk
- = (final_usage, mkCoLam tagged_binders body')
- where
- (lin_binders,other_binders) = splitAt (getContextSize stk) binders
- new_env = env `addNewCands` lin_binders
- (body_usage, body') = occAnal new_env (lamOnContext stk (length lin_binders))
- (mkCoLam other_binders body)
- (final_usage, tagged_binders) = tagBinders body_usage lin_binders
-
-occAnal env stk (CoLam binders body)
- = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
- where
- new_env = env `addNewCands` binders
- (body_usage, body') = occAnal new_env (lamOnContext stk (length binders)) body
- (final_usage, tagged_binders) = tagBinders body_usage binders
-
-{-
-occAnal env (CoLam binders body)
- = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
- where
- new_env = env `addNewCands` binders
- (body_usage, body') = occAnal new_env body
- (final_usage, tagged_binders) = tagBinders body_usage binders
--}
-
-occAnal env stk (CoTyLam tyvar body)
- = (new_body_usage, CoTyLam tyvar body')
- where
- (body_usage, body') = occAnal env stk body
- new_body_usage = if isLinContext stk
- then body_usage
- else mapIdEnv markDangerousToDup body_usage
-
-occAnal env stk (CoCase scrut alts)
- = (scrut_usage `combineUsageDetails` alts_usage,
- CoCase scrut' alts')
- where
- (scrut_usage, scrut') = occAnal env initContext scrut
- (alts_usage, alts') = occAnalAlts env stk alts
-
-
-occAnal env stk (CoLet bind body)
- = (final_usage , foldr CoLet body' new_binds) -- mkCoLets* wants PlainCore... (sigh)
- where
- new_env = env `addNewCands` (bindersOf bind)
- (body_usage, body') = occAnal new_env stk {- ?? -} body
- (final_usage, new_binds) = --BSCC("occAnalBind2")
- occAnalBind env bind body_usage
- --ESCC
-\end{code}
-
-Case alternatives
-~~~~~~~~~~~~~~~~~
-\begin{code}
-occAnalAlts env stk (CoAlgAlts alts deflt)
- = (foldr combineAltsUsageDetails deflt_usage alts_usage,
- -- Note: combine*Alts*UsageDetails...
- CoAlgAlts alts' deflt')
- where
- (alts_usage, alts') = unzip (map do_alt alts)
- (deflt_usage, deflt') = occAnalDeflt env stk deflt
-
- do_alt (con, args, rhs)
- = (final_usage, (con, tagged_args, rhs'))
- where
- new_env = env `addNewCands` args
- (rhs_usage, rhs') = occAnal new_env stk rhs
- (final_usage, tagged_args) = tagBinders rhs_usage args
-
-occAnalAlts env stk (CoPrimAlts alts deflt)
- = (foldr combineAltsUsageDetails deflt_usage alts_usage,
- -- Note: combine*Alts*UsageDetails...
- CoPrimAlts alts' deflt')
- where
- (alts_usage, alts') = unzip (map do_alt alts)
- (deflt_usage, deflt') = occAnalDeflt env stk deflt
-
- do_alt (lit, rhs)
- = (rhs_usage, (lit, rhs'))
- where
- (rhs_usage, rhs') = occAnal env stk rhs
-
-occAnalDeflt env stk CoNoDefault = (emptyDetails, CoNoDefault)
-
-occAnalDeflt env stk (CoBindDefault binder rhs)
- = (final_usage, CoBindDefault tagged_binder rhs')
- where
- new_env = env `addNewCand` binder
- (rhs_usage, rhs') = occAnal new_env stk rhs
- (final_usage, tagged_binder) = tagBinder rhs_usage binder
-\end{code}
-
-
-Atoms
-~~~~~
-\begin{code}
-occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
-
-occAnalAtoms env atoms
- = foldr do_one_atom emptyDetails atoms
- where
- do_one_atom (CoLitAtom lit) usage = usage
- do_one_atom (CoVarAtom v) usage
- | isCandidate env v = addOneOcc usage v (argOccurrence 0)
- | otherwise = usage
-
-
-occAnalArgAtoms :: OccEnv -> [(PlainCoreAtom,ArgUsage)] -> UsageDetails
-occAnalArgAtoms env atoms
- = foldr do_one_atom emptyDetails atoms
- where
- do_one_atom (CoLitAtom lit,_) usage = usage
- do_one_atom (CoVarAtom v,ArgUsage ar) usage
- | isCandidate env v = addOneOcc usage v (argOccurrence ar)
- | otherwise = usage
- do_one_atom (CoVarAtom v,UnknownArgUsage) usage
- | isCandidate env v = addOneOcc usage v (argOccurrence 0)
- | otherwise = usage
-
-occAnalAtom :: OccEnv -> PlainCoreAtom -> UsageDetails
-
-occAnalAtom env (CoLitAtom lit) = emptyDetails
-occAnalAtom env (CoVarAtom v)
- | isCandidate env v = unitDetails v (argOccurrence 0)
- | otherwise = emptyDetails
---
--- This function looks for (fully) applied calls to special ids.
---
-occAnalApp
- :: OccEnv
- -> Context
- -> [PlainCoreArg]
- -> PlainCoreExpr
- -> (UsageDetails, -- Gives info only about the "interesting" Ids
- SimplifiableCoreExpr)
-occAnalApp env stk args fun@(CoVar v)
- | not (null aut)
- && getContextSize stk >= length aut -- fully applied
- = (fun_usage `combineUsageDetails` arg_usages,
- applyToArgs fun' args)
- where
- val_args = [ x | ValArg x <- args ]
- aut = getArgUsage (getIdArgUsageInfo v)
- (fun_usage, fun') = occAnal env stk fun
- arg_usages = occAnalArgAtoms env (zip val_args aut)
-occAnalApp env stk args (CoApp fun arg)
- = occAnalApp env (incContext stk) (ValArg arg:args) fun
-occAnalApp env stk args (CoTyApp fun arg)
- = occAnalApp env stk (TypeArg arg:args) fun
-occAnalApp env stk args fun
- = (fun_usage `combineUsageDetails` arg_usages,
- applyToArgs fun' args)
- where
- (fun_usage, fun') = occAnal env stk fun
- arg_usages = occAnalAtoms env val_args
- val_args = [ x | ValArg x <- args ]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[OccurAnal-main]{Counting occurrences: main function}
-%* *
-%************************************************************************
-
-Abstract, but simple rep. for stacks.
-\begin{code}
-data Context = Context Int Bool
- -- if b then n > 0
- -- ie. you *can't* have a linear content with *no* arguments.
-
-lamOnContext :: Context -> Int -> Context
-lamOnContext (Context n b) i = mkContext (max 0 (n - i)) b
-
-isLinContext :: Context -> Bool
-isLinContext (Context n b) = b
-
-getContextSize :: Context -> Int
-getContextSize (Context n b) = n
-
-incContext :: Context -> Context
-incContext (Context n u) = Context (n + 1) u
-
-initContext :: Context
-initContext = Context 0 False
-
-shareContext :: Context -> Context
-shareContext (Context n u) = mkContext n False
-
-mkContext :: Int -> Bool -> Context
-mkContext 0 _ = Context 0 False
-mkContext i b = Context i b
-
-mkContextFromBinderInfo :: BinderInfo -> Context
-mkContextFromBinderInfo (DeadCode) = mkContext 0 False
-mkContextFromBinderInfo (ManyOcc i) = mkContext i False
-mkContextFromBinderInfo bi@(OneOcc _ _ _ _ i)
- = mkContext i (oneSafeOcc True bi)
-\end{code}
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface OccurAnal where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..))
-import PrimOps(PrimOp)
-import TaggedCore(SimplifiableCoreBinding(..), SimplifiableCoreExpr(..))
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data BinderInfo
-data GlobalSwitch
-data CoreBinding a b
-data CoreExpr a b
-data Id
-type PlainCoreExpr = CoreExpr Id Id
-type PlainCoreProgram = [CoreBinding Id Id]
-type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id
-type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-occurAnalyseBinds :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> (SimplifierSwitch -> Bool) -> [CoreBinding (Id, BinderInfo) Id]
-occurAnalyseExpr :: UniqFM Id -> CoreExpr Id Id -> (UniqFM BinderInfo, CoreExpr (Id, BinderInfo) Id)
-occurAnalyseGlobalExpr :: CoreExpr Id Id -> CoreExpr (Id, BinderInfo) Id
-
%* *
%************************************************************************
-The occurrence analyser analyses the way in which variables are used
-in their scope, and pins that information on the binder. It does {\em
-not} take any strategic decisions about what to do as a result (eg
-discard binding, inline binding etc). That's the job of the
-simplifier.
-
-The occurrence analyser {\em simply} records usage information. That is,
-it pins on each binder info on how that binder occurs in its scope.
-
-Any uses within the RHS of a let(rec) binding for a variable which is
-itself unused are ignored. For example:
-@
- let x = ...
- y = ...x...
- in
- x+1
-@
-Here, y is unused, so x will be marked as appearing just once.
-
-An exported Id gets tagged as ManyOcc.
-
-IT MUST OBSERVE SCOPING: CANNOT assume unique binders.
-
-Lambdas
-~~~~~~~
-The occurrence analyser marks each binder in a lambda the same way.
-Thus:
- \ x y -> f y x
-will have both x and y marked as single occurrence, and *not* dangerous-to-dup.
-Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup,
-but the simplifer very carefully takes care of this special case.
-(See the CoLam case in simplExpr.)
-
-Why? Because typically applications are saturated, in which case x is *not*
-dangerous-to-dup.
-
-Things to muse upon
-~~~~~~~~~~~~~~~~~~~
-
-There *is* a reason not to substitute for
-variables applied to types: it can undo the effect of floating
-Consider:
-\begin{verbatim}
- c = /\a -> e
- f = /\b -> let d = c b
- in \ x::b -> ...
-\end{verbatim}
-Here, inlining c would be a Bad Idea.
-
-At present I've set it up so that the "inside-lambda" flag sets set On for
-type-lambdas too, which effectively prevents such substitutions. I don't *think*
-it disables any interesting ones either.
+The occurrence analyser re-typechecks a core expression, returning a new
+core expression with (hopefully) improved usage information.
\begin{code}
#include "HsVersions.h"
module OccurAnal (
- occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
+ occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
-- and to make the interface self-sufficient...
- CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
- PlainCoreProgram(..), PlainCoreExpr(..),
- SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
) where
-IMPORT_Trace
-import Outputable -- ToDo: rm; debugging
-import Pretty
-
-import PlainCore -- the stuff we read...
-import TaggedCore -- ... and produce Simplifiable*
-
-import AbsUniType
+import Type
import BinderInfo
import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) )
import Digraph ( stronglyConnComp )
-import Id ( eqId, idWantsToBeINLINEd, isConstMethodId_maybe,
+import Id ( eqId, idWantsToBeINLINEd, isConstMethodId,
isSpecPragmaId_maybe, SpecInfo )
-import IdEnv
import Maybes
import UniqSet
import Util
%************************************************************************
\begin{code}
-data OccEnv = OccEnv
- Bool -- Keep-unused-bindings flag
- -- False <=> OK to chuck away binding
- -- and ignore occurrences within it
- Bool -- Keep-spec-pragma-ids flag
- -- False <=> OK to chuck away spec pragma bindings
- -- and ignore occurrences within it
- Bool -- Keep-conjurable flag
- -- False <=> OK to throw away *dead*
- -- "conjurable" Ids; at the moment, that
- -- *only* means constant methods, which
- -- are top-level. A use of a "conjurable"
- -- Id may appear out of thin air -- e.g.,
- -- specialiser conjuring up refs to const
- -- methods.
- Bool -- IgnoreINLINEPragma flag
- -- False <=> OK to use INLINEPragma information
- -- True <=> ignore INLINEPragma information
- (UniqSet Id) -- Candidates
+data OccEnv =
+ OccEnv
+ Bool -- Keep-unused-bindings flag
+ -- False <=> OK to chuck away binding
+ -- and ignore occurrences within it
+ Bool -- Keep-spec-pragma-ids flag
+ -- False <=> OK to chuck away spec pragma bindings
+ -- and ignore occurrences within it
+ Bool -- Keep-conjurable flag
+ -- False <=> OK to throw away *dead*
+ -- "conjurable" Ids; at the moment, that
+ -- *only* means constant methods, which
+ -- are top-level. A use of a "conjurable"
+ -- Id may appear out of thin air -- e.g.,
+ -- specialiser conjuring up refs to const methods.
+ Bool -- IgnoreINLINEPragma flag
+ -- False <=> OK to use INLINEPragma information
+ -- True <=> ignore INLINEPragma information
+ (UniqSet Id) -- Candidates
addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
- = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
+addNewCands (OccEnv kd ks kc ip cands) ids
+ = OccEnv kd ks kc ip (cands `unionUniqSets` mkUniqSet ids)
addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
- = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
+addNewCand (OccEnv ks kd kc ip cands) id
+ = OccEnv kd ks kc ip (cands `unionUniqSets` singletonUniqSet id)
isCandidate :: OccEnv -> Id -> Bool
isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
ignoreINLINEPragma :: OccEnv -> Bool
-ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
+ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip
keepUnusedBinding :: OccEnv -> Id -> Bool
keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
- = keep_dead || (keep_spec && is_spec)
- where
- is_spec = maybeToBool (isSpecPragmaId_maybe binder)
+ = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
keepBecauseConjurable :: OccEnv -> Id -> Bool
keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
- = keep_conjurable && is_conjurable
- where
- is_conjurable = maybeToBool (isConstMethodId_maybe binder)
+ = keep_conjurable && isConstMethodId binder
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
Just info -> info
isNeeded env usage binder
- = case usage_of usage binder of
+ = case usage_of usage binder of
DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
other -> True
\end{code}
\begin{code}
occurAnalyseBinds
- :: [PlainCoreBinding] -- input
+ :: [CoreBinding] -- input
-> (GlobalSwitch -> Bool)
-> (SimplifierSwitch -> Bool)
-> [SimplifiableCoreBinding] -- output
\begin{code}
occurAnalyseExpr :: UniqSet Id -- Set of interesting free vars
- -> PlainCoreExpr
+ -> CoreExpr
-> (IdEnv BinderInfo, -- Occ info for interesting free vars
SimplifiableCoreExpr)
False {- Do not ignore INLINE Pragma -}
candidates
-occurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
+occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
occurAnalyseGlobalExpr expr
- = -- Top level expr, so no interesting free vars, and
+ = -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr
\end{code}
\begin{code}
occAnalBind :: OccEnv
- -> PlainCoreBinding
+ -> CoreBinding
-> UsageDetails -- Usage details of scope
-> (UsageDetails, -- Of the whole let(rec)
[SimplifiableCoreBinding])
-occAnalBind env (CoNonRec binder rhs) body_usage
+occAnalBind env (NonRec binder rhs) body_usage
| isNeeded env body_usage binder -- It's mentioned in body
= (final_body_usage `combineUsageDetails` rhs_usage,
- [CoNonRec tagged_binder rhs'])
+ [NonRec tagged_binder rhs'])
| otherwise
= (body_usage, [])
This seems to miss an obvious improvement.
@
- letrec f = ...g...
- g = ...f...
- in
+ letrec f = ...g...
+ g = ...f...
+ in
...g...
===>
\begin{code}
-occAnalBind env (CoRec pairs) body_usage
+occAnalBind env (Rec pairs) body_usage
= foldr do_final_bind (body_usage, []) sccs
where
analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
-
+
lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
lookup id = assoc "occAnalBind:lookup" analysed_pairs id
---- stuff for dependency analysis of binds -------------------------------
edges :: [(Id,Id)] -- (a,b) means a mentions b
- edges = concat [ edges_from binder rhs_usage
+ edges = concat [ edges_from binder rhs_usage
| (binder, (rhs_usage, _)) <- analysed_pairs]
edges_from :: Id -> UsageDetails -> [(Id,Id)]
(combined_usage, tagged_binder) = tagBinder total_usage binder
new_bind
- | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
- | otherwise = CoNonRec tagged_binder rhs'
+ | mentions_itself binder rhs_usage = Rec [(tagged_binder,rhs')]
+ | otherwise = NonRec tagged_binder rhs'
where
mentions_itself binder usage
= maybeToBool (lookupIdEnv usage binder)
total_usage = foldr combineUsageDetails body_usage rhs_usages
(combined_usage, tagged_binders) = tagBinders total_usage sCC
- new_bind = CoRec (tagged_binders `zip` rhss')
+ new_bind = Rec (tagged_binders `zip` rhss')
\end{code}
@occAnalRhs@ deals with the question of bindings where the Id is marked
\begin{code}
occAnalRhs :: OccEnv
-> Id -- Binder
- -> PlainCoreExpr -- Rhs
+ -> CoreExpr -- Rhs
-> (UsageDetails, SimplifiableCoreExpr)
occAnalRhs env id rhs
~~~~~~~~~~~
\begin{code}
occAnal :: OccEnv
- -> PlainCoreExpr
+ -> CoreExpr
-> (UsageDetails, -- Gives info only about the "interesting" Ids
SimplifiableCoreExpr)
-occAnal env (CoVar v)
+occAnal env (Var v)
| isCandidate env v
- = (unitIdEnv v (funOccurrence 0), CoVar v)
+ = (unitIdEnv v (funOccurrence 0), Var v)
| otherwise
- = (emptyDetails, CoVar v)
+ = (emptyDetails, Var v)
-occAnal env (CoLit lit) = (emptyDetails, CoLit lit)
-occAnal env (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
-occAnal env (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
+occAnal env (Lit lit) = (emptyDetails, Lit lit)
+occAnal env (Con con tys args) = (occAnalAtoms env args, Con con tys args)
+occAnal env (Prim op tys args) = (occAnalAtoms env args, Prim op tys args)
-occAnal env (CoSCC cc body)
- = (mapIdEnv markInsideSCC usage, CoSCC cc body')
+occAnal env (SCC cc body)
+ = (mapIdEnv markInsideSCC usage, SCC cc body')
where
(usage, body') = occAnal env body
-occAnal env (CoApp fun arg)
- = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
+occAnal env (App fun arg)
+ = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
where
(fun_usage, fun') = occAnal env fun
arg_usage = occAnalAtom env arg
-
+
occAnal env (CoTyApp fun ty)
= (fun_usage, CoTyApp fun' ty)
where
(fun_usage, fun') = occAnal env fun
-occAnal env (CoLam binders body)
- = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
+occAnal env (Lam binder body)
+ = (mapIdEnv markDangerousToDup final_usage, Lam tagged_binder body')
where
- new_env = env `addNewCands` binders
- (body_usage, body') = occAnal new_env body
- (final_usage, tagged_binders) = tagBinders body_usage binders
+ (body_usage, body') = occAnal (env `addNewCand` binder) body
+ (final_usage, tagged_binder) = tagBinder body_usage binder
-- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
occAnal env (CoTyLam tyvar body)
where
(body_usage, body') = occAnal env body
-occAnal env (CoCase scrut alts)
+occAnal env (Case scrut alts)
= (scrut_usage `combineUsageDetails` alts_usage,
- CoCase scrut' alts')
+ Case scrut' alts')
where
(scrut_usage, scrut') = occAnal env scrut
(alts_usage, alts') = occAnalAlts env alts
-occAnal env (CoLet bind body)
- = (final_usage, foldr CoLet body' new_binds) -- mkCoLet* wants PlainCore... (sigh)
+occAnal env (Let bind body)
+ = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
where
new_env = env `addNewCands` (bindersOf bind)
(body_usage, body') = occAnal new_env body
Case alternatives
~~~~~~~~~~~~~~~~~
\begin{code}
-occAnalAlts env (CoAlgAlts alts deflt)
+occAnalAlts env (AlgAlts alts deflt)
= (foldr combineAltsUsageDetails deflt_usage alts_usage,
-- Note: combine*Alts*UsageDetails...
- CoAlgAlts alts' deflt')
+ AlgAlts alts' deflt')
where
(alts_usage, alts') = unzip (map do_alt alts)
(deflt_usage, deflt') = occAnalDeflt env deflt
(rhs_usage, rhs') = occAnal new_env rhs
(final_usage, tagged_args) = tagBinders rhs_usage args
-occAnalAlts env (CoPrimAlts alts deflt)
+occAnalAlts env (PrimAlts alts deflt)
= (foldr combineAltsUsageDetails deflt_usage alts_usage,
-- Note: combine*Alts*UsageDetails...
- CoPrimAlts alts' deflt')
+ PrimAlts alts' deflt')
where
(alts_usage, alts') = unzip (map do_alt alts)
(deflt_usage, deflt') = occAnalDeflt env deflt
where
(rhs_usage, rhs') = occAnal env rhs
-occAnalDeflt env CoNoDefault = (emptyDetails, CoNoDefault)
+occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
-occAnalDeflt env (CoBindDefault binder rhs)
- = (final_usage, CoBindDefault tagged_binder rhs')
+occAnalDeflt env (BindDefault binder rhs)
+ = (final_usage, BindDefault tagged_binder rhs')
where
new_env = env `addNewCand` binder
(rhs_usage, rhs') = occAnal new_env rhs
Atoms
~~~~~
\begin{code}
-occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
+occAnalAtoms :: OccEnv -> [CoreArg] -> UsageDetails
occAnalAtoms env atoms
= foldr do_one_atom emptyDetails atoms
where
- do_one_atom (CoLitAtom lit) usage = usage
- do_one_atom (CoVarAtom v) usage
+ do_one_atom (LitArg lit) usage = usage
+ do_one_atom (VarArg v) usage
| isCandidate env v = addOneOcc usage v (argOccurrence 0)
- | otherwise = usage
+ | otherwise = usage
-occAnalAtom :: OccEnv -> PlainCoreAtom -> UsageDetails
+occAnalAtom :: OccEnv -> CoreArg -> UsageDetails
-occAnalAtom env (CoLitAtom lit) = emptyDetails
-occAnalAtom env (CoVarAtom v)
+occAnalAtom env (LitArg lit) = emptyDetails
+occAnalAtom env (VarArg v)
| isCandidate env v = unitDetails v (argOccurrence 0)
| otherwise = emptyDetails
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SAT where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PlainCore(PlainCoreProgram(..))
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-data CoreBinding a b
-data CoreExpr a b
-data Id
-type PlainCoreProgram = [CoreBinding Id Id]
-doStaticArgs :: [CoreBinding Id Id] -> SplitUniqSupply -> [CoreBinding Id Id]
-
therefore there is no penalty in keeping them.
Experimental Evidence: Heap: +/- 7%
- Instrs: Always improves for 2 or more Static Args.
+ Instrs: Always improves for 2 or more Static Args.
\begin{code}
#include "HsVersions.h"
module SAT (
- doStaticArgs,
+ doStaticArgs
-- and to make the interface self-sufficient...
- PlainCoreProgram(..), CoreExpr, CoreBinding, Id
) where
-import IdEnv
import Maybes ( Maybe(..) )
-import PlainCore
import SATMonad
-import SplitUniq
import Util
\end{code}
\begin{code}
-doStaticArgs :: PlainCoreProgram -> SplitUniqSupply -> PlainCoreProgram
+doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
doStaticArgs binds
= initSAT (mapSAT sat_bind binds)
where
- sat_bind (CoNonRec binder expr)
+ sat_bind (NonRec binder expr)
= emptyEnvSAT `thenSAT_`
satExpr expr `thenSAT` (\ expr' ->
- returnSAT (CoNonRec binder expr') )
- sat_bind (CoRec [(binder,rhs)])
+ returnSAT (NonRec binder expr') )
+ sat_bind (Rec [(binder,rhs)])
= emptyEnvSAT `thenSAT_`
insSAEnv binder (getArgLists rhs) `thenSAT_`
satExpr rhs `thenSAT` (\ rhs' ->
saTransform binder rhs')
- sat_bind (CoRec pairs)
+ sat_bind (Rec pairs)
= emptyEnvSAT `thenSAT_`
mapSAT satExpr rhss `thenSAT` \ rhss' ->
- returnSAT (CoRec (binders `zip` rhss'))
+ returnSAT (Rec (binders `zip` rhss'))
where
(binders, rhss) = unzip pairs
\end{code}
\begin{code}
-satAtom (CoVarAtom v)
+satAtom (VarArg v)
= updSAEnv (Just (v,([],[]))) `thenSAT_`
returnSAT ()
\end{code}
\begin{code}
-satExpr :: PlainCoreExpr -> SatM PlainCoreExpr
+satExpr :: CoreExpr -> SatM CoreExpr
-satExpr var@(CoVar v)
+satExpr var@(Var v)
= updSAEnv (Just (v,([],[]))) `thenSAT_`
returnSAT var
-satExpr lit@(CoLit _) = returnSAT lit
+satExpr lit@(Lit _) = returnSAT lit
-satExpr e@(CoCon con types args)
+satExpr e@(Con con types args)
= mapSAT satAtom args `thenSAT_`
returnSAT e
-satExpr e@(CoPrim prim ty args)
+satExpr e@(Prim prim ty args)
= mapSAT satAtom args `thenSAT_`
returnSAT e
-satExpr (CoLam binders body)
+satExpr (Lam binders body)
= satExpr body `thenSAT` \ body' ->
- returnSAT (CoLam binders body')
+ returnSAT (Lam binders body')
satExpr (CoTyLam tyvar body)
= satExpr body `thenSAT` (\ body' ->
returnSAT (CoTyLam tyvar body') )
-satExpr app@(CoApp _ _)
+satExpr app@(App _ _)
= getAppArgs app
satExpr app@(CoTyApp _ _)
= getAppArgs app
-satExpr (CoCase expr alts)
+satExpr (Case expr alts)
= satExpr expr `thenSAT` \ expr' ->
sat_alts alts `thenSAT` \ alts' ->
- returnSAT (CoCase expr' alts')
+ returnSAT (Case expr' alts')
where
- sat_alts (CoAlgAlts alts deflt)
+ sat_alts (AlgAlts alts deflt)
= mapSAT satAlgAlt alts `thenSAT` \ alts' ->
sat_default deflt `thenSAT` \ deflt' ->
- returnSAT (CoAlgAlts alts' deflt')
+ returnSAT (AlgAlts alts' deflt')
where
satAlgAlt (con, params, rhs)
= satExpr rhs `thenSAT` \ rhs' ->
returnSAT (con, params, rhs')
- sat_alts (CoPrimAlts alts deflt)
+ sat_alts (PrimAlts alts deflt)
= mapSAT satPrimAlt alts `thenSAT` \ alts' ->
sat_default deflt `thenSAT` \ deflt' ->
- returnSAT (CoPrimAlts alts' deflt')
+ returnSAT (PrimAlts alts' deflt')
where
satPrimAlt (lit, rhs)
= satExpr rhs `thenSAT` \ rhs' ->
returnSAT (lit, rhs')
- sat_default CoNoDefault
- = returnSAT CoNoDefault
- sat_default (CoBindDefault binder rhs)
+ sat_default NoDefault
+ = returnSAT NoDefault
+ sat_default (BindDefault binder rhs)
= satExpr rhs `thenSAT` \ rhs' ->
- returnSAT (CoBindDefault binder rhs')
+ returnSAT (BindDefault binder rhs')
-satExpr (CoLet (CoNonRec binder rhs) body)
+satExpr (Let (NonRec binder rhs) body)
= satExpr body `thenSAT` \ body' ->
satExpr rhs `thenSAT` \ rhs' ->
- returnSAT (CoLet (CoNonRec binder rhs') body')
+ returnSAT (Let (NonRec binder rhs') body')
-satExpr (CoLet (CoRec [(binder,rhs)]) body)
+satExpr (Let (Rec [(binder,rhs)]) body)
= satExpr body `thenSAT` \ body' ->
insSAEnv binder (getArgLists rhs) `thenSAT_`
satExpr rhs `thenSAT` \ rhs' ->
saTransform binder rhs' `thenSAT` \ binding ->
- returnSAT (CoLet binding body')
+ returnSAT (Let binding body')
-satExpr (CoLet (CoRec binds) body)
+satExpr (Let (Rec binds) body)
= let
(binders, rhss) = unzip binds
in
satExpr body `thenSAT` \ body' ->
mapSAT satExpr rhss `thenSAT` \ rhss' ->
- returnSAT (CoLet (CoRec (binders `zip` rhss')) body')
+ returnSAT (Let (Rec (binders `zip` rhss')) body')
-satExpr (CoSCC cc expr)
+satExpr (SCC cc expr)
= satExpr expr `thenSAT` \ expr2 ->
- returnSAT (CoSCC cc expr2)
-
--- ToDo: DPH stuff
+ returnSAT (SCC cc expr2)
\end{code}
\begin{code}
-getAppArgs :: PlainCoreExpr -> SatM PlainCoreExpr
+getAppArgs :: CoreExpr -> SatM CoreExpr
getAppArgs app
= get app `thenSAT` \ (app',result) ->
updSAEnv result `thenSAT_`
returnSAT app'
where
- get :: PlainCoreExpr
- -> SatM (PlainCoreExpr, Maybe (Id, SATInfo))
+ get :: CoreExpr
+ -> SatM (CoreExpr, Maybe (Id, SATInfo))
get (CoTyApp e ty)
= get e `thenSAT` \ (e',result) ->
Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
)
- get (CoApp e a)
+ get (App e a)
= get e `thenSAT` \ (e', result) ->
satAtom a `thenSAT_`
let si = case a of
- (CoVarAtom v) -> Static v
+ (VarArg v) -> Static v
_ -> NotStatic
in
returnSAT (
- CoApp e' a,
+ App e' a,
case result of
Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
Nothing -> Nothing
)
- get var@(CoVar v)
+ get var@(Var v)
= returnSAT (var, Just (v,([],[])))
get e
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SATMonad where
-import CoreSyn(CoreBinding, CoreExpr)
-import Id(Id)
-import Maybes(Labda)
-import PlainCore(PlainCoreExpr(..))
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-import UniqFM(UniqFM)
-infixr 9 `thenSAT`
-infixr 9 `thenSAT_`
-data Arg a = Static a | NotStatic
-data Id
-type PlainCoreExpr = CoreExpr Id Id
-type SATEnv = UniqFM ([Arg UniType], [Arg Id])
-type SATInfo = ([Arg UniType], [Arg Id])
-type SatM a = SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (a, UniqFM ([Arg UniType], [Arg Id]))
-data SplitUniqSupply
-data UniType
-dropStatics :: [Arg a] -> [b] -> [b]
-emptyEnvSAT :: SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id]))
-getArgLists :: CoreExpr Id Id -> ([Arg UniType], [Arg Id])
-getSATInfo :: Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (Labda ([Arg UniType], [Arg Id]), UniqFM ([Arg UniType], [Arg Id]))
-initSAT :: (SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (a, UniqFM ([Arg UniType], [Arg Id]))) -> SplitUniqSupply -> a
-insSAEnv :: Id -> ([Arg UniType], [Arg Id]) -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id]))
-isStatic :: Arg a -> Bool
-mapSAT :: (a -> SplitUniqSupply -> c -> (b, c)) -> [a] -> SplitUniqSupply -> c -> ([b], c)
-newSATName :: Id -> UniType -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (Id, UniqFM ([Arg UniType], [Arg Id]))
-returnSAT :: b -> a -> c -> (b, c)
-saTransform :: Id -> CoreExpr Id Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (CoreBinding Id Id, UniqFM ([Arg UniType], [Arg Id]))
-thenSAT :: (SplitUniqSupply -> c -> (a, b)) -> (a -> SplitUniqSupply -> b -> d) -> SplitUniqSupply -> c -> d
-thenSAT_ :: (SplitUniqSupply -> c -> (a, b)) -> (SplitUniqSupply -> b -> d) -> SplitUniqSupply -> c -> d
-updSAEnv :: Labda (Id, ([Arg UniType], [Arg Id])) -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id]))
-instance Eq a => Eq (Arg a)
-
returnSAT, thenSAT, thenSAT_, mapSAT, getSATInfo, newSATName,
getArgLists, Arg(..), insSAEnv, saTransform,
- SATEnv(..), isStatic, dropStatics,
-
- Id, UniType, SplitUniqSupply, PlainCoreExpr(..)
+ SATEnv(..), isStatic, dropStatics
) where
-import AbsUniType ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
- extractTyVarsFromTy, splitType, splitTyArgs,
+import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
+ extractTyVarsFromTy, splitSigmaTy, splitTyArgs,
glueTyArgs, instantiateTy, TauType(..),
Class, ThetaType(..), SigmaType(..),
InstTyEnv(..)
)
-import IdEnv
-import Id ( mkSysLocal, getIdUniType )
+import Id ( mkSysLocal, idType )
import Maybes ( Maybe(..) )
-import PlainCore
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
-import SplitUniq
-import Unique
+import UniqSupply
import Util
infixr 9 `thenSAT`, `thenSAT_`
\begin{code}
type SATEnv = IdEnv SATInfo
-type SATInfo = ([Arg UniType],[Arg Id])
+type SATInfo = ([Arg Type],[Arg Id])
data Arg a = Static a | NotStatic
deriving Eq
\begin{code}
type SatM result
- = SplitUniqSupply -> SATEnv -> (result, SATEnv)
+ = UniqSupply -> SATEnv -> (result, SATEnv)
-initSAT :: SatM a -> SplitUniqSupply -> a
+initSAT :: SatM a -> UniqSupply -> a
initSAT f us = fst (f us nullIdEnv)
getSATInfo var us env
= (lookupIdEnv env var, env)
-newSATName :: Id -> UniType -> SatM Id
+newSATName :: Id -> Type -> SatM Id
newSATName id ty us env
- = case (getSUnique us) of { unique ->
+ = case (getUnique us) of { unique ->
(mkSysLocal new_str unique ty mkUnknownSrcLoc, env) }
where
new_str = getOccurrenceName id _APPEND_ SLIT("_sat")
-getArgLists :: PlainCoreExpr -> ([Arg UniType],[Arg Id])
+getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
getArgLists expr
= let
- (tvs, lambda_bounds, body) = digForLambdas expr
+ (uvs, tvs, lambda_bounds, body) = digForLambdas expr
in
([ Static (mkTyVarTy tv) | tv <- tvs ],
[ Static v | v <- lambda_bounds ])
-dropArgs :: PlainCoreExpr -> PlainCoreExpr
-dropArgs (CoLam v e) = dropArgs e
-dropArgs (CoTyLam ty e) = dropArgs e
+dropArgs :: CoreExpr -> CoreExpr
+dropArgs (Lam _ e) = dropArgs e
+dropArgs (CoTyLam _ e) = dropArgs e
dropArgs e = e
-
\end{code}
We implement saTransform using shadowing of binders, that is
we transform
map = \f as -> case as of
- [] -> []
- (a':as') -> let x = f a'
- y = map f as'
- in x:y
+ [] -> []
+ (a':as') -> let x = f a'
+ y = map f as'
+ in x:y
to
map = \f as -> let map = \f as -> map' as
- in let rec map' = \as -> case as of
- [] -> []
- (a':as') -> let x = f a'
- y = map f as'
- in x:y
- in map' as
+ in let rec map' = \as -> case as of
+ [] -> []
+ (a':as') -> let x = f a'
+ y = map f as'
+ in x:y
+ in map' as
the inner map should get inlined and eliminated.
\begin{code}
-saTransform :: Id -> PlainCoreExpr -> SatM PlainCoreBinding
+saTransform :: Id -> CoreExpr -> SatM CoreBinding
saTransform binder rhs
= getSATInfo binder `thenSAT` \ r ->
case r of
-- [Andre] test: do it only if we have more than one static argument.
- --Just (tyargs,args) | any isStatic args
+ --Just (tyargs,args) | any isStatic args
Just (tyargs,args) | length (filter isStatic args) > 1
-> newSATName binder (new_ty tyargs args) `thenSAT` \ binder' ->
mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs ->
trace ("SAT "++ show (length (filter isStatic args))) (
- returnSAT (CoNonRec binder new_rhs)
- )
- _ -> returnSAT (CoRec [(binder, rhs)])
+ returnSAT (NonRec binder new_rhs)
+ )
+ _ -> returnSAT (Rec [(binder, rhs)])
where
mkNewRhs binder binder' tyargs args rhs
= let
get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
get_nsa (_:args) (_:as) = get_nsa args as
- local_body = foldl CoApp (CoVar binder')
- [CoVarAtom a | a <- non_static_args]
+ local_body = foldl App (Var binder')
+ [VarArg a | a <- non_static_args]
nonrec_rhs = origLams local_body
- -- HACK! The following is a fake SysLocal binder with
+ -- HACK! The following is a fake SysLocal binder with
-- *the same* unique as binder.
-- the reason for this is the following:
-- this binder *will* get inlined but if it happen to be
-- top-level or exported somehow.
-- A better fix is to use binder directly but with the TopLevel
-- tag (or Exported tag) modified.
- fake_binder = mkSysLocal
- (getOccurrenceName binder _APPEND_ SLIT("_fsat"))
- (getTheUnique binder)
- (getIdUniType binder)
- mkUnknownSrcLoc
- rec_body = mkCoLam non_static_args
- ( CoLet (CoNonRec fake_binder nonrec_rhs)
- {-in-} (dropArgs rhs))
+ fake_binder = mkSysLocal
+ (getOccurrenceName binder _APPEND_ SLIT("_fsat"))
+ (getItsUnique binder)
+ (idType binder)
+ mkUnknownSrcLoc
+ rec_body = mkValLam non_static_args
+ ( Let (NonRec fake_binder nonrec_rhs)
+ {-in-} (dropArgs rhs))
in
returnSAT (
- origLams (CoLet (CoRec [(binder',rec_body)]) {-in-} local_body)
+ origLams (Let (Rec [(binder',rec_body)]) {-in-} local_body)
)
where
origLams = origLams' rhs
- where
- origLams' (CoLam v e) e' = mkCoLam v (origLams' e e')
- origLams' (CoTyLam ty e) e' = CoTyLam ty (origLams' e e')
- origLams' _ e' = e'
+ where
+ origLams' (Lam v e) e' = Lam v (origLams' e e')
+ origLams' (CoTyLam ty e) e' = CoTyLam ty (origLams' e e')
+ origLams' _ e' = e'
new_ty tyargs args
- = instantiateTy (mk_inst_tyenv tyargs tv_tmpl)
+ = instantiateTy (mk_inst_tyenv tyargs tv_tmpl)
(mkSigmaTy tv_tmpl' dict_tys' tau_ty')
where
-- get type info for the local function:
- (tv_tmpl, dict_tys, tau_ty) = (splitType . getIdUniType) binder
+ (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
(reg_arg_tys, res_type) = splitTyArgs tau_ty
-- now, we drop the ones that are
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SetLevels where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import Outputable(Outputable)
-import SplitUniq(SplitUniqSupply)
-data Level = Level Int Int | Top
-incMinorLvl :: Level -> Level
-isTopLvl :: Level -> Bool
-ltLvl :: Level -> Level -> Bool
-ltMajLvl :: Level -> Level -> Bool
-setLevels :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding (Id, Level) Id]
-tOP_LEVEL :: Level
-instance Outputable Level
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section{SetLevels}
module SetLevels (
setLevels,
- Level(..), tOP_LEVEL,
-
+ Level(..), tOP_LEVEL,
+
incMinorLvl, ltMajLvl, ltLvl, isTopLvl
-- not exported: , incMajorLvl, isTopMajLvl, unTopify
) where
-import PlainCore
-
-
-import AbsUniType ( isPrimType, isLeakFreeType, mkTyVarTy,
+import Type ( isPrimType, isLeakFreeType, mkTyVarTy,
quantifyTy, TyVarTemplate -- Needed for quantifyTy
)
import AnnCoreSyn
-import BasicLit ( BasicLit(..) )
+import Literal ( Literal(..) )
import CmdLineOpts ( GlobalSwitch(..) )
import FreeVars
-import Id ( mkSysLocal, getIdUniType, eqId,
+import Id ( mkSysLocal, idType, eqId,
isBottomingId, toplevelishId, DataCon(..)
IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
)
-import IdEnv
import Maybes ( Maybe(..) )
import Pretty -- debugging only
-import PrimKind ( PrimKind(..) )
import UniqSet
import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import TyVarEnv
-import SplitUniq
-import Unique
+import UniqSupply
import Util
\end{code}
| Top -- Means *really* the top level.
\end{code}
-
+
The {\em level number} on a (type-)lambda-bound variable is the
nesting depth of the (type-)lambda which binds it. On an expression, it's the
maximum level number of its free (type-)variables. On a let(rec)-bound
makes it go right to the top.
The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@). That's
-meant to be the level number of the enclosing binder in the final (floated)
+meant to be the level number of the enclosing binder in the final (floated)
program. If the level number of a sub-expression is less than that of the
context, then it might be worth let-binding the sub-expression so that it
-will indeed float. This context level starts at @Level 0 0@; it is never @Top@.
+will indeed float. This context level starts at @Level 0 0@; it is never @Top@.
\begin{code}
-type LevelledExpr = CoreExpr (Id, Level) Id
-type LevelledAtom = CoreAtom Id
-type LevelledBind = CoreBinding (Id, Level) Id
+type LevelledExpr = GenCoreExpr (Id, Level) Id
+type LevelledAtom = GenCoreAtom Id
+type LevelledBind = GenCoreBinding (Id, Level) Id
type LevelEnvs = (IdEnv Level, -- bind Ids to levels
TyVarEnv Level) -- bind type variables to levels
maxLvl :: Level -> Level -> Level
maxLvl Top l2 = l2
maxLvl l1 Top = l1
-maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
+maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
| (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
| otherwise = l2
ltLvl :: Level -> Level -> Bool
ltLvl l1 Top = False
ltLvl Top (Level _ _) = True
-ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) ||
+ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) ||
(maj1 == maj2 && min1 < min2)
ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft
ltMajLvl l1 Top = False
ltMajLvl Top (Level 0 _) = False
ltMajLvl Top (Level _ _) = True
-ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
+ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
isTopLvl :: Level -> Bool
isTopLvl Top = True
%************************************************************************
\begin{code}
-setLevels :: [PlainCoreBinding]
+setLevels :: [CoreBinding]
-> (GlobalSwitch -> Bool) -- access to all global cmd-line opts
- -> SplitUniqSupply
+ -> UniqSupply
-> [LevelledBind]
setLevels binds sw us
-- "do_them"'s main business is to thread the monad along
-- It gives each top binding the same empty envt, because
-- things unbound in the envt have level number zero implicitly
- do_them :: [PlainCoreBinding] -> LvlM [LevelledBind]
+ do_them :: [CoreBinding] -> LvlM [LevelledBind]
do_them [] = returnLvl []
do_them (b:bs)
initial_envs = (nullIdEnv, nullTyVarEnv)
-- OLDER:
-lvlTopBind (CoNonRec binder rhs)
+lvlTopBind (NonRec binder rhs)
= lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder (freeVars rhs))
-- Rhs can have no free vars!
-lvlTopBind (CoRec pairs)
+lvlTopBind (Rec pairs)
= lvlBind (Level 0 0) initial_envs (AnnCoRec [(b,freeVars rhs) | (b,rhs) <- pairs])
{- NEWER: Too bad about the types: WDP:
-lvlTopBind (CoNonRec binder rhs)
+lvlTopBind (NonRec binder rhs)
= {-SIGH:wrong type: ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} -- Rhs can have no free vars!
lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder emptyUniqSet)
-lvlTopBind (CoRec pairs)
+lvlTopBind (Rec pairs)
= lvlBind (Level 0 0) initial_envs
(AnnCoRec [(b, emptyUniqSet)
| (b, rhs) <- pairs,
let
new_envs = (addOneToIdEnv venv name final_lvl, tenv)
in
- returnLvl ([CoNonRec (name, final_lvl) rhs'], new_envs)
+ returnLvl ([NonRec (name, final_lvl) rhs'], new_envs)
where
- ty = getIdUniType name
+ ty = idType name
lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs)
binders_w_lvls = binders `zip` repeat final_lvl
new_envs = (growIdEnvList venv binders_w_lvls, tenv)
in
- returnLvl (extra_binds ++ [CoRec (binders_w_lvls `zip` rhss')], new_envs)
+ returnLvl (extra_binds ++ [Rec (binders_w_lvls `zip` rhss')], new_envs)
where
(binders,rhss) = unzip pairs
\end{code}
If there were another lambda in @r@'s rhs, it would get level-2 as well.
\begin{code}
-lvlExpr _ _ (_, AnnCoVar v) = returnLvl (CoVar v)
-lvlExpr _ _ (_, AnnCoLit l) = returnLvl (CoLit l)
-lvlExpr _ _ (_, AnnCoCon con tys atoms) = returnLvl (CoCon con tys atoms)
-lvlExpr _ _ (_, AnnCoPrim op tys atoms) = returnLvl (CoPrim op tys atoms)
+lvlExpr _ _ (_, AnnCoVar v) = returnLvl (Var v)
+lvlExpr _ _ (_, AnnCoLit l) = returnLvl (Lit l)
+lvlExpr _ _ (_, AnnCoCon con tys atoms) = returnLvl (Con con tys atoms)
+lvlExpr _ _ (_, AnnCoPrim op tys atoms) = returnLvl (Prim op tys atoms)
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoTyApp expr ty)
+lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoTyApp expr ty)
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
returnLvl (CoTyApp expr' ty)
lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoApp fun arg)
= lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
- returnLvl (CoApp fun' arg)
+ returnLvl (App fun' arg)
lvlExpr ctxt_lvl envs (_, AnnCoSCC cc expr)
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
- returnLvl (CoSCC cc expr')
+ returnLvl (SCC cc expr')
lvlExpr ctxt_lvl (venv, tenv) (_, AnnCoTyLam tyvar e)
= lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
where
incd_lvl = incMinorLvl ctxt_lvl
new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
-
-{- if we were splitting lambdas:
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam [arg] rhs)
- = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
- returnLvl (CoLam arg_w_lvl rhs')
- where
- incd_lvl = incMajorLvl ctxt_lvl
- arg_w_lvl = [(arg, incd_lvl)]
- new_venv = growIdEnvList venv arg_w_lvl
-
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam (a:args) rhs)
- = lvlExpr incd_lvl (new_venv, tenv) (AnnCoLam args rhs) `thenLvl` \ rhs' ->
- -- don't use mkCoLam!
- returnLvl (CoLam arg_w_lvl rhs')
- where
- incd_lvl = incMajorLvl ctxt_lvl
- arg_w_lvl = [(a,incd_lvl)]
- new_venv = growIdEnvList venv arg_w_lvl
--}
-
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam args rhs)
- = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
- returnLvl (CoLam args_w_lvls rhs')
+
+lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam arg rhs)
+ = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
+ returnLvl (Lam (arg,incd_lvl) rhs')
where
- incd_lvl = incMajorLvl ctxt_lvl
- args_w_lvls = [ (a, incd_lvl) | a <- args ]
- new_venv = growIdEnvList venv args_w_lvls
+ incd_lvl = incMajorLvl ctxt_lvl
+ new_venv = growIdEnvList venv [(arg,incd_lvl)]
lvlExpr ctxt_lvl envs (_, AnnCoLet bind body)
= lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) ->
lvlExpr ctxt_lvl new_envs body `thenLvl` \ body' ->
- returnLvl (foldr CoLet body' binds') -- mkCoLet* requires PlainCore...
+ returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoCase expr alts)
= lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' ->
lvl_alts alts `thenLvl` \ alts' ->
- returnLvl (CoCase expr' alts')
+ returnLvl (Case expr' alts')
where
- expr_type = typeOfCoreExpr (deAnnotate expr)
+ expr_type = coreExprType (deAnnotate expr)
incd_lvl = incMinorLvl ctxt_lvl
lvl_alts (AnnCoAlgAlts alts deflt)
= mapLvl lvl_alt alts `thenLvl` \ alts' ->
lvl_deflt deflt `thenLvl` \ deflt' ->
- returnLvl (CoAlgAlts alts' deflt')
+ returnLvl (AlgAlts alts' deflt')
where
lvl_alt (con, bs, e)
= let
lvl_alts (AnnCoPrimAlts alts deflt)
= mapLvl lvl_alt alts `thenLvl` \ alts' ->
lvl_deflt deflt `thenLvl` \ deflt' ->
- returnLvl (CoPrimAlts alts' deflt')
+ returnLvl (PrimAlts alts' deflt')
where
- lvl_alt (lit, e)
+ lvl_alt (lit, e)
= lvlMFE incd_lvl envs e `thenLvl` \ e' ->
returnLvl (lit, e')
- lvl_deflt AnnCoNoDefault = returnLvl CoNoDefault
+ lvl_deflt AnnCoNoDefault = returnLvl NoDefault
lvl_deflt (AnnCoBindDefault b expr)
= let
new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
in
lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
- returnLvl (CoBindDefault (b, incd_lvl) expr')
+ returnLvl (BindDefault (b, incd_lvl) expr')
\end{code}
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
ctxt_lvl envs ann_expr ty `thenLvl` \ (final_lvl, expr') ->
returnLvl expr'
where
- ty = typeOfCoreExpr (deAnnotate ann_expr)
-\end{code}
+ ty = coreExprType (deAnnotate ann_expr)
+\end{code}
%************************************************************************
are being created as let-bindings
Decision tree:
-Let Bound?
+Let Bound?
YES. -> (a) try abstracting type variables.
If we abstract type variables it will go further, that is, past more
lambdas. same as asking if the level number given by the free
- variables is less than the level number given by free variables
+ variables is less than the level number given by free variables
and type variables together.
- Abstract offending type variables, e.g.
+ Abstract offending type variables, e.g.
change f ty a b
to let v = /\ty' -> f ty' a b
- in v ty
+ in v ty
so that v' is not stopped by the level number of ty
tag the original let with its level number
(from its variables and type variables)
- NO. is a WHNF?
- YES. -> No point in let binding to float a WHNF.
- Pin (leave) expression here.
- NO. -> Will float past a lambda?
- (check using free variables only, not type variables)
- YES. -> do the same as (a) above.
- NO. -> No point in let binding if it is not going anywhere
- Pin (leave) expression here.
+ NO. is a WHNF?
+ YES. -> No point in let binding to float a WHNF.
+ Pin (leave) expression here.
+ NO. -> Will float past a lambda?
+ (check using free variables only, not type variables)
+ YES. -> do the same as (a) above.
+ NO. -> No point in let binding if it is not going anywhere
+ Pin (leave) expression here.
\begin{code}
setFloatLevel :: Bool -- True <=> the expression is already let-bound
-- False <=> it's a possible MFE
-> Level -- of context
- -> LevelEnvs
+ -> LevelEnvs
-> CoreExprWithFVs -- Original rhs
- -> UniType -- Type of rhs
+ -> Type -- Type of rhs
-> LvlM (Level, -- Level to attribute to this let-binding
LevelledExpr) -- Final rhs
-setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
+setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
expr@(FVInfo fvs tfvs might_leak, _) ty
-- Invariant: ctxt_lvl is never = Top
-- Beautiful ASSERT, dudes (WDP 95/04)...
-- If this gives any problems we could restrict the idea to things destined
-- for top level.
- | not alreadyLetBound
+ | not alreadyLetBound
&& (manifestly_whnf || not will_float_past_lambda)
- = -- Pin whnf non-let-bound expressions,
+ = -- Pin whnf non-let-bound expressions,
-- or ones which aren't going anywhere useful
lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
returnLvl (ctxt_lvl, expr')
returnLvl (maybe_unTopify expr_lvl, expr')
| otherwise -- This will create a let anyway, even if there is no
- -- type variable to abstract, so we try to abstract anyway
- = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
- `thenLvl` \ final_expr ->
+ -- type variable to abstract, so we try to abstract anyway
+ = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
+ `thenLvl` \ final_expr ->
returnLvl (expr_lvl, final_expr)
-- OLD LIE: The body of the let, just a type application, isn't worth floating
-- so pin it with ctxt_lvl
lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
will_float_past_lambda = -- Will escape lambda if let-bound
- ids_only_lvl `ltMajLvl` ctxt_lvl
+ ids_only_lvl `ltMajLvl` ctxt_lvl
- worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
- -- if type abstracted
+ worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
+ -- if type abstracted
(ids_only_lvl `ltLvl` tyvars_only_lvl)
&& not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
de_ann_expr = deAnnotate expr
is_trivial (CoTyApp e _) = is_trivial e
- is_trivial (CoVar _) = True
+ is_trivial (Var _) = True
is_trivial _ = False
offending_tyvars = filter offending tv_list
maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
maybe_unTopify lvl = lvl
{- ToDo [Andre]: the line above (maybe) should be Level 1 0,
- -- so that the let will not go past the *last* lambda if it can
- -- generate a space leak. If it is already in major level 0
- -- It won't do any harm to give it a Level 1 0.
- -- we should do the same test not only for things with level Top,
- -- but also for anything that gets a major level 0.
- the problem is that
- f = \a -> let x = [1..1000]
- in zip a x
- ==>
- f = let x = [1..1000]
- in \a -> zip a x
- is just as bad as floating x to the top level.
- Notice it would be OK in cases like
- f = \a -> let x = [1..1000]
- y = length x
- in a + y
- ==>
- f = let x = [1..1000]
- y = length x
- in \a -> a + y
- as x will be gc'd after y is updated.
- [We did not hit any problems with the above (Level 0 0) code
- in nofib benchmark]
- -}
+ -- so that the let will not go past the *last* lambda if it can
+ -- generate a space leak. If it is already in major level 0
+ -- It won't do any harm to give it a Level 1 0.
+ -- we should do the same test not only for things with level Top,
+ -- but also for anything that gets a major level 0.
+ the problem is that
+ f = \a -> let x = [1..1000]
+ in zip a x
+ ==>
+ f = let x = [1..1000]
+ in \a -> zip a x
+ is just as bad as floating x to the top level.
+ Notice it would be OK in cases like
+ f = \a -> let x = [1..1000]
+ y = length x
+ in a + y
+ ==>
+ f = let x = [1..1000]
+ y = length x
+ in \a -> a + y
+ as x will be gc'd after y is updated.
+ [We did not hit any problems with the above (Level 0 0) code
+ in nofib benchmark]
+ -}
\end{code}
Abstract wrt tyvars, by making it just as if we had seen
variables, then we just return E.
\begin{code}
-abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
+abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
= lvlExpr incd_lvl new_envs expr `thenLvl` \ expr' ->
newLvlVar poly_ty `thenLvl` \ poly_var ->
let
poly_var_rhs = mkCoTyLam offending_tyvars expr'
- poly_var_binding = CoNonRec (poly_var, lvl) poly_var_rhs
- poly_var_app = mkCoTyApps (CoVar poly_var) (map mkTyVarTy offending_tyvars)
- final_expr = CoLet poly_var_binding poly_var_app -- mkCoLet* requires PlainCore
+ poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
+ poly_var_app = mkCoTyApps (Var poly_var) (map mkTyVarTy offending_tyvars)
+ final_expr = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
in
returnLvl final_expr
where
-- These defns are just like those in the TyLam case of lvlExpr
(incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
- next lvl tyvar = (lvl1, (tyvar,lvl1))
+ next lvl tyvar = (lvl1, (tyvar,lvl1))
where lvl1 = incMinorLvl lvl
new_tenv = growTyVarEnvList tenv tyvar_lvls
x1 = e1
...
xn = en
- in
+ in
body
to
- letrec
+ letrec
x1' = /\ ab -> let D' in e1
...
xn' = /\ ab -> let D' in en
need be, and D is a bunch of simple type applications:
x1_cl = x1' ab
- ...
+ ...
xn_cl = xn' ab
The "_cl" indicates that in D, the level numbers on the xi are the context level
similar:
x1_ll = x1' ab
- ...
+ ...
xn_ll = xn' ab
-but differ in their level numbers; here the ab are the newly-introduced
+but differ in their level numbers; here the ab are the newly-introduced
type lambdas.
\begin{code}
-}
| ids_only_lvl `ltLvl` tyvars_only_lvl
- = -- Abstract wrt tyvars;
+ = -- Abstract wrt tyvars;
-- offending_tyvars is definitely non-empty
-- (I love the ASSERT to check this... WDP 95/02)
let
-- These defns are just like those in the TyLam case of lvlExpr
(incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
- next lvl tyvar = (lvl1, (tyvar,lvl1))
+ next lvl tyvar = (lvl1, (tyvar,lvl1))
where lvl1 = incMinorLvl lvl
- ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
+ ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
new_tenv = growTyVarEnvList tenv tyvar_lvls
new_venv = growIdEnvList venv ids_w_incd_lvl
new_envs = (new_venv, new_tenv)
mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' ->
mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
let
- ids_w_poly_vars = ids `zip` poly_vars
+ ids_w_poly_vars = ids `zip` poly_vars
-- The "d_rhss" are the right-hand sides of "D" and "D'"
-- in the documentation above
- d_rhss = [ mkCoTyApps (CoVar poly_var) offending_tyvar_tys | poly_var <- poly_vars]
+ d_rhss = [ mkCoTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
-- "local_binds" are "D'" in the documentation above
- local_binds = zipWith CoNonRec ids_w_incd_lvl d_rhss
+ local_binds = zipWithEqual NonRec ids_w_incd_lvl d_rhss
- poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr CoLet rhs' local_binds)
- | rhs' <- rhss' -- mkCoLet* requires PlainCore...
+ poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr Let rhs' local_binds)
+ | rhs' <- rhss' -- mkCoLet* requires Core...
]
poly_binds = [(poly_var, ids_only_lvl) | poly_var <- poly_vars] `zip` poly_var_rhss
-
+
in
- returnLvl (ctxt_lvl, [CoRec poly_binds], d_rhss)
+ returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
-- The new right-hand sides, just a type application, aren't worth floating
-- so pin it with ctxt_lvl
returnLvl (expr_lvl, [], rhss')
where
- tys = map getIdUniType ids
+ tys = map idType ids
fvs = unionManyUniqSets [freeVarsOf rhs | rhs <- rhss] `minusUniqSet` mkUniqSet ids
tfvs = unionManyUniqSets [freeTyVarsOf rhs | rhs <- rhss]
tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
- offending_tyvars
+ offending_tyvars
| ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
| otherwise = []
offending_tyvar_tys = map mkTyVarTy offending_tyvars
- poly_tys = [ snd (quantifyTy offending_tyvars ty)
+ poly_tys = [ snd (quantifyTy offending_tyvars ty)
| ty <- tys
]
{- ******** OMITTED NOW
isWorthFloating :: Bool -- True <=> already let-bound
- -> PlainCoreExpr -- The expression
+ -> CoreExpr -- The expression
-> Bool
isWorthFloating alreadyLetBound expr
| otherwise = -- No point in adding a fresh let-binding for a WHNF, because
-- floating it isn't beneficial enough.
- isWorthFloatingExpr expr &&
+ isWorthFloatingExpr expr &&
not (manifestlyWHNF expr || manifestlyBottom expr)
********** -}
-isWorthFloatingExpr :: PlainCoreExpr -> Bool
-isWorthFloatingExpr (CoVar v) = False
-isWorthFloatingExpr (CoLit lit) = False
-isWorthFloatingExpr (CoCon con tys []) = False -- Just a type application
-isWorthFloatingExpr (CoTyApp expr ty) = isWorthFloatingExpr expr
+isWorthFloatingExpr :: CoreExpr -> Bool
+isWorthFloatingExpr (Var v) = False
+isWorthFloatingExpr (Lit lit) = False
+isWorthFloatingExpr (Con con tys []) = False -- Just a type application
+isWorthFloatingExpr (CoTyApp expr ty) = isWorthFloatingExpr expr
isWorthFloatingExpr other = True
-canFloatToTop :: (UniType, CoreExprWithFVs) -> Bool
+canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
\begin{code}
type LvlM result
- = (GlobalSwitch -> Bool) -> SplitUniqSupply -> result
+ = (GlobalSwitch -> Bool) -> UniqSupply -> result
thenLvl m k sw us
= case splitUniqSupply us of { (s1, s2) ->
applications, to give them a fighting chance of being floated.
\begin{code}
-newLvlVar :: UniType -> LvlM Id
+newLvlVar :: Type -> LvlM Id
newLvlVar ty sw us
= id
where
id = mkSysLocal SLIT("lvl") uniq ty mkUnknownSrcLoc
- uniq = getSUnique us
+ uniq = getUnique us
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplCase where
-import BinderInfo(BinderInfo)
-import CoreSyn(CoreBinding, CoreCaseAlternatives, CoreExpr)
-import Id(Id)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-bindLargeRhs :: SimplEnv -> [(Id, BinderInfo)] -> UniType -> (SimplEnv -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> SplitUniqSupply -> SimplCount -> ((CoreBinding Id Id, CoreExpr (Id, BinderInfo) Id), SimplCount)
-simplCase :: SimplEnv -> CoreExpr (Id, BinderInfo) Id -> CoreCaseAlternatives (Id, BinderInfo) Id -> (SimplEnv -> CoreExpr (Id, BinderInfo) Id -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> UniType -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-
module SimplCase ( simplCase, bindLargeRhs ) where
-IMPORT_Trace
-import Pretty -- these are for debugging only
-import Outputable
-
import SimplMonad
import SimplEnv
-import TaggedCore
-import PlainCore
-import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp,
+import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp,
voidPrimTy, voidPrimId, mkFunTy, primOpOkForSpeculation
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( splitType, splitTyArgs, glueTyArgs,
+import Type ( splitSigmaTy, splitTyArgs, glueTyArgs,
getTyConFamilySize, isPrimType,
- getUniDataTyCon_maybe
+ maybeDataTyCon
)
-import BasicLit ( isNoRepLit, BasicLit, PrimKind )
+import Literal ( isNoRepLit, Literal )
import CmdLineOpts ( SimplifierSwitch(..) )
import Id
import IdInfo
-> OutUniType -- Type of result expression
-> SmplM OutExpr
-simplCase env (CoLet bind body) alts rhs_c result_ty
+simplCase env (Let bind body) alts rhs_c result_ty
| not (switchIsSet env SimplNoLetFromCase)
= -- Float the let outside the case scrutinee (if not disabled by flag)
tick LetFloatFromCase `thenSmpl_`
===>
let b = \ x y -> body
in
- case e of
+ case e of
p1 -> case rhs1 of (x,y) -> b x y
...
pn -> case rhsn of (x,y) -> b x y
\begin{code}
-simplCase env (CoCase inner_scrut inner_alts) outer_alts rhs_c result_ty
+simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
| switchIsSet env SimplCaseOfCase
= -- Ha! Do case-of-case
tick CaseOfCase `thenSmpl_`
if no_need_to_bind_large_alts
then
- simplCase env inner_scrut inner_alts
+ simplCase env inner_scrut inner_alts
(\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
else
bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
let
rhs_c' = \env rhs -> simplExpr env rhs []
in
- simplCase env inner_scrut inner_alts
+ simplCase env inner_scrut inner_alts
(\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
result_ty
`thenSmpl` \ case_expr ->
returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
where
- no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
+ no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
isSingleton (nonErrorRHSs inner_alts)
\end{code}
tick CaseOfError `thenSmpl_`
rhs_c env retyped_error_app
where
- alts_ty = typeOfCoreAlts (unTagBindersAlts alts)
+ alts_ty = coreAltsType (unTagBindersAlts alts)
maybe_error_app = maybeErrorApp scrut (Just alts_ty)
Just retyped_error_app = maybe_error_app
\end{code}
-> SmplM OutExpr -- The whole case expression
\end{code}
-Scrutinising a literal or constructor.
+Scrutinising a literal or constructor.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's an obvious win to do:
Sanity check: we don't have a good
story to tell about case analysis on NoRep things. ToDo.
-\begin{code}
-completeCase env (CoLit lit) alts rhs_c
+\begin{code}
+completeCase env (Lit lit) alts rhs_c
| not (isNoRepLit lit)
= -- Ha! Select the appropriate alternative
tick KnownBranch `thenSmpl_`
completePrimCaseWithKnownLit env lit alts rhs_c
-completeCase env expr@(CoCon con tys con_args) alts rhs_c
+completeCase env expr@(Con con tys con_args) alts rhs_c
= -- Ha! Staring us in the face -- select the appropriate alternative
tick KnownBranch `thenSmpl_`
completeAlgCaseWithKnownCon env con tys con_args alts rhs_c
case x of
0# -> ...
other -> ...(case x of
- 0# -> ...
+ 0# -> ...
other -> ...) ...
\end{code}
Here the inner case can be eliminated. This really only shows up in
case e of ===> r
True -> r
False -> r
-
+
We only do this for very cheaply compared r's (constructors, literals
and variables). If pedantic bottoms is on, we only do it when the
scrutinee is a PrimOp which can't fail.
3. Check we can safely ditch the case:
* PedanticBottoms is off,
or * the scrutinee is an already-evaluated variable
- or * the scrutinee is a primop which is ok for speculation
+ or * the scrutinee is a primop which is ok for speculation
-- ie we want to preserve divide-by-zero errors, and
-- calls to error itself!
completeCase env scrut alts rhs_c
| switchIsSet env SimplDoCaseElim &&
- binders_unused &&
+ binders_unused &&
all_rhss_same &&
- (not (switchIsSet env SimplPedanticBottoms) ||
+ (not (switchIsSet env SimplPedanticBottoms) ||
scrut_is_evald ||
scrut_is_eliminable_primitive ||
rhs1_is_scrutinee ||
scrut_is_var_and_single_strict_default
)
-
+
= tick CaseElim `thenSmpl_`
rhs_c new_env rhs1
where
-- whether none of their binders are used
(binders_unused, possible_rhss, new_env)
= case alts of
- CoPrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
+ PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
deflt_rhs ++ rhss,
new_env)
where
-- Eliminate unused rhss if poss
rhss = case scrut_form of
- OtherLiteralForm not_these -> [rhs | (alt_lit,rhs) <- alts,
+ OtherLitForm not_these -> [rhs | (alt_lit,rhs) <- alts,
not (alt_lit `is_elem` not_these)
]
other -> [rhs | (_,rhs) <- alts]
- CoAlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
+ AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
new_env)
where
-- Eliminate unused alts if poss
possible_alts = case scrut_form of
- OtherConstructorForm not_these ->
+ OtherConForm not_these ->
-- Remove alts which can't match
[alt | alt@(alt_con,_,_) <- alts,
not (alt_con `is_elem` not_these)]
#ifdef DEBUG
--- ConstructorForm c t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (ppr PprDebug alts))
- -- ConstructorForm can't happen, since we'd have
+-- ConForm c t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (ppr PprDebug alts))
+ -- ConForm can't happen, since we'd have
-- inlined it, and be in completeCaseWithKnownCon by now
#endif
other -> alts
-- If the scrutinee is a variable, look it up to see what we know about it
scrut_form = case scrut of
- CoVar v -> lookupUnfolding env v
+ Var v -> lookupUnfolding env v
other -> NoUnfoldingDetails
- -- If the scrut is already eval'd then there's no worry about
+ -- If the scrut is already eval'd then there's no worry about
-- eliminating the case
scrut_is_evald = case scrut_form of
- OtherLiteralForm _ -> True
- ConstructorForm _ _ _ -> True
- OtherConstructorForm _ -> True
+ OtherLitForm _ -> True
+ ConForm _ _ _ -> True
+ OtherConForm _ -> True
other -> False
scrut_is_eliminable_primitive
= case scrut of
- CoPrim op _ _ -> primOpOkForSpeculation op
- CoVar _ -> case alts of
- CoPrimAlts _ _ -> True -- Primitive, hence non-bottom
- CoAlgAlts _ _ -> False -- Not primitive
+ Prim op _ _ -> primOpOkForSpeculation op
+ Var _ -> case alts of
+ PrimAlts _ _ -> True -- Primitive, hence non-bottom
+ AlgAlts _ _ -> False -- Not primitive
other -> False
-
+
-- case v of w -> e{strict in w} ===> e[v/w]
scrut_is_var_and_single_strict_default
= case scrut of
- CoVar _ -> case alts of
- CoAlgAlts [] (CoBindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
- other -> False
+ Var _ -> case alts of
+ AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
+ other -> False
other -> False
- elim_deflt_binder CoNoDefault -- No Binder
- = (True, [], env)
- elim_deflt_binder (CoBindDefault (id, DeadCode) rhs) -- Binder unused
+ elim_deflt_binder NoDefault -- No Binder
+ = (True, [], env)
+ elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
= (True, [rhs], env)
- elim_deflt_binder (CoBindDefault used_binder rhs) -- Binder used
+ elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
= case scrut of
- CoVar v -> -- Binder used, but can be eliminated in favour of scrut
- (True, [rhs], extendIdEnvWithAtom env used_binder (CoVarAtom v))
+ Var v -> -- Binder used, but can be eliminated in favour of scrut
+ (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
non_var -> -- Binder used, and can't be elimd
(False, [rhs], env)
-- Check whether the chosen unique rhs (ie rhs1) is the same as
-- the scrutinee. Remember that the rhs is as yet unsimplified.
rhs1_is_scrutinee = case (scrut, rhs1) of
- (CoVar scrut_var, CoVar rhs_var)
+ (Var scrut_var, Var rhs_var)
-> case lookupId env rhs_var of
- Just (ItsAnAtom (CoVarAtom rhs_var'))
+ Just (ItsAnAtom (VarArg rhs_var'))
-> rhs_var' == scrut_var
other -> False
other -> False
Scrutinising anything else. If it's a variable, it can't be bound to a
constructor or literal, because that would have been inlined
-\begin{code}
+\begin{code}
completeCase env scrut alts rhs_c
= simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
mkCoCase scrut alts'
\begin{code}
-bindLargeAlts :: SimplEnv
- -> InAlts
+bindLargeAlts :: SimplEnv
+ -> InAlts
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
-> OutUniType -- Result type
-> SmplM ([OutBinding], -- Extra bindings
InAlts) -- Modified alts
-bindLargeAlts env the_lot@(CoAlgAlts alts deflt) rhs_c rhs_ty
+bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
= mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
- returnSmpl (deflt_bindings ++ alt_bindings, CoAlgAlts alts' deflt')
+ returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
where
- do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
+ do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
(\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
returnSmpl (bind, (con,args,rhs'))
-bindLargeAlts env the_lot@(CoPrimAlts alts deflt) rhs_c rhs_ty
+bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
= mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
- returnSmpl (deflt_bindings ++ alt_bindings, CoPrimAlts alts' deflt')
+ returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
where
do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
(\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
returnSmpl (bind, (lit,rhs'))
-bindLargeDefault env CoNoDefault rhs_ty rhs_c
- = returnSmpl ([], CoNoDefault)
-bindLargeDefault env (CoBindDefault binder rhs) rhs_ty rhs_c
- = bindLargeRhs env [binder] rhs_ty
+bindLargeDefault env NoDefault rhs_ty rhs_c
+ = returnSmpl ([], NoDefault)
+bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
+ = bindLargeRhs env [binder] rhs_ty
(\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
- returnSmpl ([bind], CoBindDefault binder rhs')
+ returnSmpl ([bind], BindDefault binder rhs')
\end{code}
bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
- | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
+ | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
rhs_id x1 .. xn)
\begin{code}
-- with potentially-disastrous strictness results. So
-- instead we turn it into a function: \v -> e
-- where v::VoidPrim. Since arguments of type
- -- VoidPrim don't generate any code, this gives the
+ -- 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 voidPrimTy `thenSmpl` \ void_arg_id ->
rhs_c env `thenSmpl` \ prim_new_body ->
- returnSmpl (CoNonRec prim_rhs_fun_id (mkCoLam [void_arg_id] prim_new_body),
- CoApp (CoVar prim_rhs_fun_id) (CoVarAtom voidPrimId))
+ returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
+ App (Var prim_rhs_fun_id) (VarArg voidPrimId))
| otherwise
= -- Make the new binding Id. NB: it's an OutId
final_rhs
= (if switchIsSet new_env SimplDoEtaReduction
then mkCoLamTryingEta
- else mkCoLam) used_args' rhs'
+ else mkValLam) used_args' rhs'
in
- returnSmpl (CoNonRec rhs_fun_id final_rhs,
- foldl CoApp (CoVar rhs_fun_id) used_arg_atoms)
+ returnSmpl (NonRec rhs_fun_id final_rhs,
+ foldl App (Var rhs_fun_id) used_arg_atoms)
-- This is slightly wierd. We're retuning an OutId as part of the
-- modified rhs, which is meant to be an InExpr. However, that's ok, because when
-- it's processed the OutId won't be found in the environment, so it
-- will be left unmodified.
where
rhs_fun_ty :: OutUniType
- rhs_fun_ty = glueTyArgs [simplTy env (getIdUniType id) | (id,_) <- used_args] rhs_ty
+ rhs_fun_ty = glueTyArgs [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
- used_arg_atoms = [CoVarAtom arg_id | (arg_id,_) <- used_args]
+ used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
dead DeadCode = True
dead other = False
it is best to make sure that \tr{default_e} mentions \tr{x} in
preference to \tr{y}. The code generator can do a cheaper job if it
doesn't have to come up with a binding for \tr{y}.
-
+
\begin{code}
simplAlts :: SimplEnv
-> OutExpr -- Simplified scrutinee;
- -- only of interest if its a var,
+ -- only of interest if its a var,
-- in which case we record its form
- -> InAlts
+ -> InAlts
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
-> SmplM OutAlts
-simplAlts env scrut (CoAlgAlts alts deflt) rhs_c
+simplAlts env scrut (AlgAlts alts deflt) rhs_c
= mapSmpl do_alt alts `thenSmpl` \ alts' ->
simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
- returnSmpl (CoAlgAlts alts' deflt')
+ returnSmpl (AlgAlts alts' deflt')
where
- deflt_form = OtherConstructorForm [con | (con,_,_) <- alts]
+ deflt_form = OtherConForm [con | (con,_,_) <- alts]
do_alt (con, con_args, rhs)
= cloneIds env con_args `thenSmpl` \ con_args' ->
let
env1 = extendIdEnvWithClones env con_args con_args'
- new_env = case scrut of
- CoVar var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args')
+ new_env = case scrut of
+ Var var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args')
other -> env1
- in
+ in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (con, con_args', rhs')
-simplAlts env scrut (CoPrimAlts alts deflt) rhs_c
+simplAlts env scrut (PrimAlts alts deflt) rhs_c
= mapSmpl do_alt alts `thenSmpl` \ alts' ->
simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
- returnSmpl (CoPrimAlts alts' deflt')
+ returnSmpl (PrimAlts alts' deflt')
where
- deflt_form = OtherLiteralForm [lit | (lit,_) <- alts]
+ deflt_form = OtherLitForm [lit | (lit,_) <- alts]
do_alt (lit, rhs)
= let
new_env = case scrut of
- CoVar var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LiteralForm lit))
+ Var var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LitForm lit))
other -> env
- in
+ in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (lit, rhs')
\end{code}
-> OutExpr -- Simplified scrutinee
-> InDefault -- Default alternative to be completed
-> UnfoldingDetails -- Gives form of scrutinee
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
+ -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
-> SmplM OutDefault
-simplDefault env scrut CoNoDefault form rhs_c
- = returnSmpl CoNoDefault
+simplDefault env scrut NoDefault form rhs_c
+ = returnSmpl NoDefault
-- Special case for variable scrutinee; see notes above.
-simplDefault env (CoVar scrut_var) (CoBindDefault binder rhs) form_from_this_case rhs_c
+simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rhs_c
= cloneId env binder `thenSmpl` \ binder' ->
let
- env1 = extendIdEnvWithAtom env binder (CoVarAtom binder')
+ env1 = extendIdEnvWithAtom env binder (VarArg binder')
-- Add form details for the default binder
scrut_form = lookupUnfolding env scrut_var
final_form
- = case (form_from_this_case, scrut_form) of
- (OtherConstructorForm cs, OtherConstructorForm ds) -> OtherConstructorForm (cs++ds)
- (OtherLiteralForm cs, OtherLiteralForm ds) -> OtherLiteralForm (cs++ds)
- -- ConstructorForm, LiteralForm impossible
+ = 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
-- Change unfold details for scrut var. We now want to unfold it
-- to binder'
- new_scrut_var_form = GeneralForm True {- OK to dup -} WhnfForm
- (CoVar binder') UnfoldAlways
+ new_scrut_var_form = GenForm True {- OK to dup -} WhnfForm
+ (Var binder') UnfoldAlways
new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
-
+
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
- returnSmpl (CoBindDefault binder' rhs')
+ returnSmpl (BindDefault binder' rhs')
-simplDefault env scrut (CoBindDefault binder rhs) form rhs_c
+simplDefault env scrut (BindDefault binder rhs) form rhs_c
= cloneId env binder `thenSmpl` \ binder' ->
let
- env1 = extendIdEnvWithAtom env binder (CoVarAtom binder')
+ env1 = extendIdEnvWithAtom env binder (VarArg binder')
new_env = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' form)
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
- returnSmpl (CoBindDefault binder' rhs')
+ returnSmpl (BindDefault binder' rhs')
\end{code}
Case alternatives when we know what the scrutinee is
\begin{code}
completePrimCaseWithKnownLit
:: SimplEnv
- -> BasicLit
+ -> Literal
-> InAlts
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
+ -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
-> SmplM OutExpr
-completePrimCaseWithKnownLit env lit (CoPrimAlts alts deflt) rhs_c
+completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
= search_alts alts
where
- search_alts :: [(BasicLit, InExpr)] -> SmplM OutExpr
+ search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
search_alts ((alt_lit, rhs) : _)
| alt_lit == lit
search_alts (_ : other_alts)
= -- This alternative doesn't match; keep looking
- search_alts other_alts
+ search_alts other_alts
search_alts []
= case deflt of
- CoNoDefault -> -- Blargh!
+ NoDefault -> -- Blargh!
panic "completePrimCaseWithKnownLit: No matching alternative and no default"
- CoBindDefault binder rhs -> -- OK, there's a default case
- -- Just bind the Id to the atom and continue
+ BindDefault binder rhs -> -- OK, there's a default case
+ -- Just bind the Id to the atom and continue
let
- new_env = extendIdEnvWithAtom env binder (CoLitAtom lit)
+ new_env = extendIdEnvWithAtom env binder (LitArg lit)
in
rhs_c new_env rhs
\end{code}
\begin{code}
completeAlgCaseWithKnownCon
:: SimplEnv
- -> DataCon -> [UniType] -> [InAtom]
+ -> DataCon -> [Type] -> [InAtom]
-- Scrutinee is (con, type, value arguments)
-> InAlts
- -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
+ -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
-> SmplM OutExpr
-completeAlgCaseWithKnownCon env con tys con_args (CoAlgAlts alts deflt) rhs_c
+completeAlgCaseWithKnownCon env con tys con_args (AlgAlts alts deflt) rhs_c
= ASSERT(isDataCon con)
search_alts alts
where
new_env = extendIdEnvWithAtomList env (zip alt_args con_args)
in
rhs_c new_env rhs
-
+
search_alts (_ : other_alts)
= -- This alternative doesn't match; keep looking
- search_alts other_alts
+ search_alts other_alts
search_alts []
= -- No matching alternative
case deflt of
- CoNoDefault -> -- Blargh!
+ NoDefault -> -- Blargh!
panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
- CoBindDefault binder rhs -> -- OK, there's a default case
+ BindDefault binder rhs -> -- OK, there's a default case
-- let-bind the binder to the constructor
cloneId env binder `thenSmpl` \ id' ->
let
env1 = extendIdEnvWithClone env binder id'
- new_env = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id'
- (ConstructorForm con tys con_args))
+ new_env = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id'
+ (ConForm con tys con_args))
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
- returnSmpl (CoLet (CoNonRec id' (CoCon con tys con_args)) rhs')
+ returnSmpl (Let (NonRec id' (Con con tys con_args)) rhs')
\end{code}
-
+
Case absorption and identity-case elimination
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
pm -> rhsm pm -> rhsm
d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
{or (prim) case v of d -> rhsn}
- pn -> rhsn ...
- ... po -> rhso[v/d]
- po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
- d' -> rhsd
+ pn -> rhsn ...
+ ... po -> rhso[v/d]
+ po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
+ d' -> rhsd
which merges two cases in one case when -- the default alternative of
the outer case scrutises the same variable as the outer case This
... ...
pm -> rhsm pm -> rhsm
d -> case d of pn -> let d = pn in rhsn
- pn -> rhsn ...
- ... po -> let d = po in rhso
- po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
- d' -> rhsd
+ pn -> rhsn ...
+ ... po -> let d = po in rhso
+ po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
+ d' -> rhsd
Here, the let's are essential, because d isn't in scope any more.
Sigh. Of course, they may be unused, in which case they'll be
eliminated on the next round. Unfortunately, we can't figure out
whether or not they are used at this juncture.
-NB: The binder in a CoBindDefault USED TO BE guaranteed unused if the
+NB: The binder in a BindDefault USED TO BE guaranteed unused if the
scrutinee is a variable, because it'll be mapped to the scrutinised
variable. Hence the [v/d] substitions can be omitted.
equation for AlgAlts, one for PrimAlts):
\begin{code}
-mkCoCase scrut (CoAlgAlts outer_alts
- (CoBindDefault deflt_var
- (CoCase (CoVar scrut_var')
- (CoAlgAlts inner_alts inner_deflt))))
+mkCoCase scrut (AlgAlts outer_alts
+ (BindDefault deflt_var
+ (Case (Var scrut_var')
+ (AlgAlts inner_alts inner_deflt))))
| (scrut_is_var && scrut_var == scrut_var') -- First transformation
|| deflt_var == scrut_var' -- Second transformation
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
- returnSmpl (CoCase scrut (CoAlgAlts (outer_alts ++ munged_reduced_inner_alts)
+ returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
(munge_alg_deflt deflt_var inner_deflt)))
- -- NB: see comment in this location for the CoPrimAlts case
+ -- NB: see comment in this location for the PrimAlts case
where
-- Check scrutinee
- scrut_is_var = case scrut of {CoVar v -> True; other -> False}
- scrut_var = case scrut of CoVar v -> v
+ scrut_is_var = case scrut of {Var v -> True; other -> False}
+ scrut_var = case scrut of Var v -> v
-- Eliminate any inner alts which are shadowed by the outer ones
reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
-- Add the lets if necessary
munged_reduced_inner_alts = map munge_alt reduced_inner_alts
- munge_alt (con, args, rhs) = (con, args, CoLet (CoNonRec deflt_var v) rhs)
+ munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
where
- v | scrut_is_var = CoVar scrut_var
- | otherwise = CoCon con arg_tys (map CoVarAtom args)
+ v | scrut_is_var = Var scrut_var
+ | otherwise = Con con arg_tys (map VarArg args)
- arg_tys = case getUniDataTyCon_maybe (getIdUniType deflt_var) of
+ arg_tys = case maybeDataTyCon (idType deflt_var) of
Just (_, arg_tys, _) -> arg_tys
-mkCoCase scrut (CoPrimAlts
- outer_alts
- (CoBindDefault deflt_var (CoCase
- (CoVar scrut_var')
- (CoPrimAlts inner_alts inner_deflt))))
+mkCoCase scrut (PrimAlts
+ outer_alts
+ (BindDefault deflt_var (Case
+ (Var scrut_var')
+ (PrimAlts inner_alts inner_deflt))))
| (scrut_is_var && scrut_var == scrut_var') ||
deflt_var == scrut_var'
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
- returnSmpl (CoCase scrut (CoPrimAlts (outer_alts ++ munged_reduced_inner_alts)
+ returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
(munge_prim_deflt deflt_var inner_deflt)))
-- Nota Bene: we don't recurse to mkCoCase again, because the
-- default will now have a binding in it that prevents
-- mkCoCase doing anything useful. Much worse, in this
-- PrimAlts case the binding in the default branch is another
- -- CoCase, so if we recurse to mkCoCase we will get into an
+ -- Case, so if we recurse to mkCoCase we will get into an
-- infinite loop.
- --
+ --
-- ToDo: think of a better way to do this. At the moment
-- there is at most one case merge per round. That's probably
-- plenty but it seems unclean somehow.
where
-- Check scrutinee
- scrut_is_var = case scrut of {CoVar v -> True; other -> False}
- scrut_var = case scrut of CoVar v -> v
+ scrut_is_var = case scrut of {Var v -> True; other -> False}
+ scrut_var = case scrut of Var v -> v
-- Eliminate any inner alts which are shadowed by the outer ones
reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
-- it isn't easy to do so right away.
munged_reduced_inner_alts = map munge_alt reduced_inner_alts
- munge_alt (lit, rhs)
- | scrut_is_var = (lit, CoCase (CoVar scrut_var)
- (CoPrimAlts [] (CoBindDefault deflt_var rhs)))
- | otherwise = (lit, CoCase (CoLit lit)
- (CoPrimAlts [] (CoBindDefault deflt_var rhs)))
+ munge_alt (lit, rhs)
+ | scrut_is_var = (lit, Case (Var scrut_var)
+ (PrimAlts [] (BindDefault deflt_var rhs)))
+ | otherwise = (lit, Case (Lit lit)
+ (PrimAlts [] (BindDefault deflt_var rhs)))
\end{code}
Now the identity-case transformation:
case e of ===> e
- True -> True;
+ True -> True;
False -> False
and similar friends.
= tick CaseIdentity `thenSmpl_`
returnSmpl scrut
where
- identity_alts (CoAlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
- identity_alts (CoPrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
+ identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
+ identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
- identity_alg_alt (con, args, CoCon con' _ args')
- = con == con' && and (zipWith eq_arg args args')
+ identity_alg_alt (con, args, Con con' _ args')
+ = con == con'
+ && and (zipWith eq_arg args args')
+ && length args == length args'
identity_alg_alt other
= False
- identity_prim_alt (lit, CoLit lit') = lit == lit'
+ identity_prim_alt (lit, Lit lit') = lit == lit'
identity_prim_alt other = False
-- For the default case we want to spot both
-- and
-- case y of { ... ; x -> y }
-- as "identity" defaults
- identity_deflt CoNoDefault = True
- identity_deflt (CoBindDefault binder (CoVar x)) = x == binder ||
- case scrut of
- CoVar y -> y == x
+ identity_deflt NoDefault = True
+ identity_deflt (BindDefault binder (Var x)) = x == binder ||
+ case scrut of
+ Var y -> y == x
other -> False
identity_deflt _ = False
- eq_arg binder (CoVarAtom x) = binder == x
+ eq_arg binder (VarArg x) = binder == x
eq_arg _ _ = False
\end{code}
The catch-all case
\begin{code}
-mkCoCase other_scrut other_alts = returnSmpl (CoCase other_scrut other_alts)
+mkCoCase other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
\end{code}
Boring local functions used above. They simply introduce a trivial binding
depending on whether it's an algebraic or primitive case.
\begin{code}
-munge_prim_deflt _ CoNoDefault = CoNoDefault
+munge_prim_deflt _ NoDefault = NoDefault
-munge_prim_deflt deflt_var (CoBindDefault d' rhs)
- = CoBindDefault deflt_var (CoCase (CoVar deflt_var)
- (CoPrimAlts [] (CoBindDefault d' rhs)))
+munge_prim_deflt deflt_var (BindDefault d' rhs)
+ = BindDefault deflt_var (Case (Var deflt_var)
+ (PrimAlts [] (BindDefault d' rhs)))
-munge_alg_deflt _ CoNoDefault = CoNoDefault
+munge_alg_deflt _ NoDefault = NoDefault
-munge_alg_deflt deflt_var (CoBindDefault d' rhs)
- = CoBindDefault deflt_var (CoLet (CoNonRec d' (CoVar deflt_var)) rhs)
+munge_alg_deflt deflt_var (BindDefault d' rhs)
+ = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
-- This line caused a generic version of munge_deflt (ie one used for
-- both alg and prim) to space leak massively. No idea why.
--- = CoBindDefault deflt_var (mkCoLetUnboxedToCase (CoNonRec d' (CoVar deflt_var)) rhs)
+-- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
\end{code}
\begin{code}
-- A cheap equality test which bales out fast!
cheap_eq :: InExpr -> InExpr -> Bool
-cheap_eq (CoVar v1) (CoVar v2) = v1==v2
-cheap_eq (CoLit l1) (CoLit l2) = l1==l2
-cheap_eq (CoCon con1 tys1 args1) (CoCon con2 tys2 args2) = (con1==con2) &&
+cheap_eq (Var v1) (Var v2) = v1==v2
+cheap_eq (Lit l1) (Lit l2) = l1==l2
+cheap_eq (Con con1 tys1 args1) (Con con2 tys2 args2) = (con1==con2) &&
(args1 `eq_args` args2)
-- Types bound to be equal
-cheap_eq (CoPrim op1 tys1 args1) (CoPrim op2 tys2 args2) = (op1==op2) &&
+cheap_eq (Prim op1 tys1 args1) (Prim op2 tys2 args2) = (op1==op2) &&
(args1 `eq_args` args2)
-- Types bound to be equal
-cheap_eq (CoApp f1 a1) (CoApp f2 a2) = (f1 `cheap_eq` f2) && (a1 `eq_atom` a2)
+cheap_eq (App f1 a1) (App f2 a2) = (f1 `cheap_eq` f2) && (a1 `eq_atom` a2)
cheap_eq (CoTyApp f1 t1) (CoTyApp f2 t2) = (f1 `cheap_eq` f2) && (t1 == t2)
cheap_eq _ _ = False
--- ToDo: make CoreAtom an instance of Eq
+-- ToDo: make CoreArg an instance of Eq
eq_args (arg1: args1) (arg2 : args2) = (arg1 `eq_atom` arg2) && (args1 `eq_args` args2)
eq_args [] [] = True
eq_args other1 other2 = False
-eq_atom (CoLitAtom l1) (CoLitAtom l2) = l1==l2
-eq_atom (CoVarAtom v1) (CoVarAtom v2) = v1==v2
+eq_atom (LitArg l1) (LitArg l2) = l1==l2
+eq_atom (VarArg v1) (VarArg v2) = v1==v2
eq_atom other1 other2 = False
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplCore where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CmdLineOpts(CoreToDo, GlobalSwitch, SwitchResult)
-import CoreSyn(CoreAtom, CoreBinding, CoreExpr)
-import FiniteMap(FiniteMap)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance)
-import Specialise(SpecialiseData(..))
-import SplitUniq(SplitUniqSupply)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Bag a
-type IdEnv a = UniqFM a
-data UnfoldingDetails
-data SpecialiseData = SpecData Bool Bool [TyCon] [TyCon] (FiniteMap TyCon [(Bool, [Labda UniType])]) (Bag (Id, [Labda UniType])) (Bag (Id, [Labda UniType])) (Bag (TyCon, [Labda UniType]))
-data UniqFM a
-data Unique
-core2core :: [CoreToDo] -> (GlobalSwitch -> SwitchResult) -> _PackedString -> PprStyle -> SplitUniqSupply -> [TyCon] -> FiniteMap TyCon [(Bool, [Labda UniType])] -> [CoreBinding Id Id] -> _State _RealWorld -> (([CoreBinding Id Id], UniqFM UnfoldingDetails, SpecialiseData), _State _RealWorld)
-
#include "HsVersions.h"
module SimplCore (
- core2core,
-
- IdEnv(..),
- UnfoldingDetails,
- SpecialiseData(..),
- UniqFM, Unique, Bag
+ core2core
) where
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import PlainCore
-
-import AbsUniType ( getTyConDataCons, alpha_ty, alpha_tyvar, beta_ty, beta_tyvar )
+import Type ( getTyConDataCons )
--SAVE:import ArityAnal ( arityAnalProgram )
import Bag
import BinderInfo ( BinderInfo) -- instances only
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import Id ( getIdUnfolding,
- getIdUniType, toplevelishId,
+ idType, toplevelishId,
idWantsToBeINLINEd,
unfoldingUnfriendlyId, isWrapperId,
mkTemplateLocals
- IF_ATTACK_PRAGMAS(COMMA getIdStrictness)
)
-import IdEnv
import IdInfo
import LiberateCase ( liberateCase )
import MainMonad
import Maybes
import SAT ( doStaticArgs )
import SCCauto
-import SimplEnv ( UnfoldingGuidance(..), SwitchChecker(..) ) -- instances
--ANDY:
--import SimplHaskell ( coreToHaskell )
import SimplMonad ( zeroSimplCount, showSimplCount, TickType, SimplCount )
import SimplPgm ( simplifyPgm )
import SimplVar ( leastItCouldCost )
import Specialise
-import SpecTyFuns ( pprSpecErrs )
+import SpecUtils ( pprSpecErrs )
import StrictAnal ( saWwTopBinds )
-#if ! OMIT_FOLDR_BUILD
-import FoldrBuildWW
+import FoldrBuildWW
import AnalFBWW
-#endif
#if ! OMIT_DEFORESTER
import Deforest ( deforestProgram )
import DefUtils ( deforestable )
#endif
-import TyVarEnv ( nullTyVarEnv )
-import SplitUniq
-import Unique
+import UniqSupply
import Util
\end{code}
-> (GlobalSwitch->SwitchResult)-- "global" command-line info lookup fn
-> FAST_STRING -- module name (profiling only)
-> PprStyle -- printing style (for debugging only)
- -> SplitUniqSupply -- a name supply
+ -> UniqSupply -- a name supply
-> [TyCon] -- local data tycons and tycon specialisations
- -> FiniteMap TyCon [(Bool, [Maybe UniType])]
- -> [PlainCoreBinding] -- input...
+ -> FiniteMap TyCon [(Bool, [Maybe Type])]
+ -> [CoreBinding] -- input...
-> MainIO
- ([PlainCoreBinding], -- results: program, plus...
+ ([CoreBinding], -- results: program, plus...
IdEnv UnfoldingDetails, -- unfoldings to be exported from here
SpecialiseData) -- specialisation data
core_todos
`thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
- (if switch_is_on D_simplifier_stats
- then writeMn stderr ("\nSimplifier Stats:\n")
+ (if switch_is_on D_simplifier_stats
+ then writeMn stderr ("\nSimplifier Stats:\n")
`thenMn_`
writeMn stderr (showSimplCount simpl_stats)
`thenMn_`
writeMn stderr "\n"
- else returnMn ()
- ) `thenMn_`
+ else returnMn ()
+ ) `thenMn_`
returnMn (processed_binds, inline_env, spec_data)
ESCC
CoreDoSimplify simpl_sw_chkr
-> BSCC("CoreSimplify")
begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
- then " (foldr/build)" else "") `thenMn_`
+ then " (foldr/build)" else "") `thenMn_`
case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of
(p, it_cnt, simpl_stats2)
-> end_pass False us2 p inline_env spec_data simpl_stats2
- ("Simplify (" ++ show it_cnt ++ ")"
+ ("Simplify (" ++ show it_cnt ++ ")"
++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
then " foldr/build" else "")
ESCC
CoreDoFoldrBuildWorkerWrapper
-#if OMIT_FOLDR_BUILD
- -> error "ERROR: CoreDoFoldrBuildWorkerWrapper: not built into compiler\n"
-#else
-> BSCC("CoreDoFoldrBuildWorkerWrapper")
begin_pass "FBWW" `thenMn_`
case (mkFoldrBuildWW switch_is_on us1 binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW"
} ESCC
-#endif
CoreDoFoldrBuildWWAnal
-#if OMIT_FOLDR_BUILD
- -> error "ERROR: CoreDoFoldrBuildWWAnal: not built into compiler\n"
-#else
-> BSCC("CoreDoFoldrBuildWWAnal")
begin_pass "AnalFBWW" `thenMn_`
case (analFBWW switch_is_on binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW"
} ESCC
-#endif
CoreLiberateCase
-> BSCC("LiberateCase")
begin_pass "FloatIn" `thenMn_`
case (floatInwards binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn"
- } ESCC
+ } ESCC
CoreDoFullLaziness
-> BSCC("CoreFloating")
spec_errs spec_warn spec_tyerrs)) ->
-- if we got errors, we die straight away
- (if not spec_noerrs ||
+ (if not spec_noerrs ||
(switch_is_on ShowImportSpecs && not (isEmptyBag spec_warn)) then
writeMn stderr (ppShow 1000 {-pprCols-}
(pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
returnMn ()) `thenMn_`
(if not spec_noerrs then -- Stop here if specialisation errors occured
- exitMn 1
+ exitMn 1
else
returnMn ()) `thenMn_`
}
ESCC
- CoreDoDeforest
+ CoreDoDeforest
#if OMIT_DEFORESTER
-> error "ERROR: CoreDoDeforest: not built into compiler\n"
#else
- -> BSCC("Deforestation")
- begin_pass "Deforestation" `thenMn_`
+ -> BSCC("Deforestation")
+ begin_pass "Deforestation" `thenMn_`
case (deforestProgram sw_chkr binds us1) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation"
- }
- ESCC
+ }
+ ESCC
#endif
-
+
CoreDoAutoCostCentres
-> BSCC("AutoSCCs")
begin_pass "AutoSCCs" `thenMn_`
}
ESCC
- CoreDoPrintCore -- print result of last pass
+ CoreDoPrintCore -- print result of last pass
-> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
simpl_stats2 what
= -- report verbosely, if required
(if (do_verbose_core2core && not print) ||
- (print && not do_verbose_core2core)
- then
+ (print && not do_verbose_core2core)
+ then
writeMn stderr ("\n*** "++what++":\n")
`thenMn_`
- writeMn stderr (ppShow 1000
+ writeMn stderr (ppShow 1000
(ppAboves (map (pprPlainCoreBinding ppr_style) binds2)))
`thenMn_`
writeMn stderr "\n"
calcInlinings :: Bool -- True => inlinings with _scc_s are OK
-> (GlobalSwitch -> SwitchResult)
-> IdEnv UnfoldingDetails
- -> [PlainCoreBinding]
+ -> [CoreBinding]
-> IdEnv UnfoldingDetails
calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds
where
pp_det NoUnfoldingDetails = ppStr "_N_"
pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
- pp_det (GeneralForm _ _ expr guide)
+ pp_det (GenForm _ _ expr guide)
= ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
pp_det other = ppStr "???"
con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
- calci inline_env (CoRec pairs)
+ calci inline_env (Rec pairs)
= foldl (calc True{-recursive-}) inline_env pairs
- calci inline_env bind@(CoNonRec binder rhs)
+ calci inline_env bind@(NonRec binder rhs)
= calc False{-not recursive-} inline_env (binder, rhs)
---------------------------------------
calc is_recursive inline_env (binder, rhs)
| not (toplevelishId binder)
= --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
- ignominious_defeat
+ ignominious_defeat
| rhs_mentions_an_unmentionable
|| (not explicit_INLINE_requested
- && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
+ && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big))
= let
my_my_trace
= if explicit_INLINE_requested
which = if scc_s_OK then " (late):" else " (early):"
in
- --pprTrace "giving up on size:" (ppCat [ppr PprDebug binder, ppr PprDebug
+ --pprTrace "giving up on size:" (ppCat [ppr PprDebug binder, ppr PprDebug
-- [rhs_mentions_an_unmentionable, explicit_INLINE_requested,
-- rhs_looks_like_a_caf, guidance_says_don't, guidance_size_too_big]]) (
my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
ignominious_defeat
#if ! OMIT_DEFORESTER
- -- For the deforester: bypass the barbed wire for recursive
+ -- For the deforester: bypass the barbed wire for recursive
-- functions that want to be inlined and are tagged deforestable
-- by the user, allowing these things to be communicated
-- across module boundaries.
- | is_recursive &&
- explicit_INLINE_requested &&
+ | is_recursive &&
+ explicit_INLINE_requested &&
deforestable binder &&
- scc_s_OK -- hack, only get them in
+ scc_s_OK -- hack, only get them in
-- calc_inlinings2
= glorious_success UnfoldAlways
-#endif
+#endif
| is_recursive && not rhs_looks_like_a_data_val
-- The only recursive defns we are prepared to tolerate at the
= --pprTrace "giving up on rec:" (ppr PprDebug binder)
ignominious_defeat
- -- Not really interested unless it's exported, but doing it
+ -- Not really interested unless it's exported, but doing it
-- this way (not worrying about export-ness) gets us all the
-- workers/specs, etc., too; which we will need for generating
-- interfaces. We are also not interested if this binder is
EssentialUnfolding -> False
UnfoldIfGoodArgs _ no_val_args arg_info_vec size
- -> if explicit_creation_threshold then
+ -> if explicit_creation_threshold then
False -- user set threshold; don't second-guess...
else if no_val_args == 0 && rhs_looks_like_a_data_val then
-- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) (
unfold_use_threshold < cost
-- )
-
+
rhs_looks_like_a_caf = not (manifestlyWHNF rhs)
rhs_looks_like_a_data_val
- = case digForLambdas rhs of
- (_, [], CoCon _ _ _) -> True
- other -> False
+ = case (digForLambdas rhs) of
+ (_, _, [], Con _ _ _) -> True
+ other -> False
rhs_arg_tys
- = case digForLambdas rhs of
- (_, val_binders, _) -> map getIdUniType val_binders
+ = case (digForLambdas rhs) of
+ (_, _, val_binders, _) -> map idType val_binders
(mentioned_ids, _, _, mentions_litlit)
= mentionedInUnfolding (\x -> x) rhs
ignominious_defeat -- and at the last hurdle, too!
\end{code}
-ANDY, on the hatred of the check above; why obliterate it? Consider
+ANDY, on the hatred of the check above; why obliterate it? Consider
head xs = foldr (\ x _ -> x) (_|_) xs
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplEnv where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo(..), DuplicationDanger, FunOrArg, InsideSCC)
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult)
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr)
-import CostCentre(CostCentre)
-import FiniteMap(FiniteMap)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(StrictnessInfo)
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda)
-import Outputable(Outputable)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import TyVarEnv(TyVarEnv(..), nullTyVarEnv)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data BasicLit
-data BinderInfo = DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int
-data DuplicationDanger
-data FunOrArg
-data InsideSCC
-data GlobalSwitch
-data SimplifierSwitch
-data CoreAtom a
-data CoreCaseAlternatives a b
-data CoreExpr a b
-data EnclosingCcDetails = NoEnclosingCcDetails | EnclosingCC CostCentre
-data FormSummary = WhnfForm | BottomForm | OtherForm
-data Id
-type IdEnv a = UniqFM a
-data IdVal = InlineIt (UniqFM IdVal) (UniqFM UniType) (CoreExpr (Id, BinderInfo) Id) | ItsAnAtom (CoreAtom Id)
-type InAlts = CoreCaseAlternatives (Id, BinderInfo) Id
-type InArg = CoreArg Id
-type InAtom = CoreAtom Id
-type InBinder = (Id, BinderInfo)
-type InBinding = CoreBinding (Id, BinderInfo) Id
-type InDefault = CoreCaseDefault (Id, BinderInfo) Id
-type InExpr = CoreExpr (Id, BinderInfo) Id
-type InId = Id
-type InIdEnv = UniqFM IdVal
-type InType = UniType
-type InTypeEnv = UniqFM UniType
-type InUniType = UniType
-data MagicUnfoldingFun
-data Labda a
-type OutAlts = CoreCaseAlternatives Id Id
-type OutArg = CoreArg Id
-type OutAtom = CoreAtom Id
-type OutBinder = Id
-type OutBinding = CoreBinding Id Id
-type OutDefault = CoreCaseDefault Id Id
-type OutExpr = CoreExpr Id Id
-type OutId = Id
-type OutType = UniType
-type OutUniType = UniType
-data SimplEnv
-type SwitchChecker a = a -> SwitchResult
-data SwitchResult
-data TyVar
-type TyVarEnv a = UniqFM a
-data UnfoldConApp
-data UnfoldEnv
-data UnfoldItem
-data UnfoldingDetails = NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance
-data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int | BadUnfolding
-data UniType
-data UniqFM a
-data Unique
-extendIdEnvWithAtom :: SimplEnv -> (Id, BinderInfo) -> CoreAtom Id -> SimplEnv
-extendIdEnvWithAtomList :: SimplEnv -> [((Id, BinderInfo), CoreAtom Id)] -> SimplEnv
-extendIdEnvWithClone :: SimplEnv -> (Id, BinderInfo) -> Id -> SimplEnv
-extendIdEnvWithClones :: SimplEnv -> [(Id, BinderInfo)] -> [Id] -> SimplEnv
-extendIdEnvWithInlining :: SimplEnv -> SimplEnv -> (Id, BinderInfo) -> CoreExpr (Id, BinderInfo) Id -> SimplEnv
-extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv
-extendTyEnvList :: SimplEnv -> [(TyVar, UniType)] -> SimplEnv
-extendUnfoldEnvGivenConstructor :: SimplEnv -> Id -> Id -> [Id] -> SimplEnv
-extendUnfoldEnvGivenFormDetails :: SimplEnv -> Id -> UnfoldingDetails -> SimplEnv
-extendUnfoldEnvGivenRhs :: SimplEnv -> (Id, BinderInfo) -> Id -> CoreExpr Id Id -> SimplEnv
-filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
-getSwitchChecker :: SimplEnv -> SimplifierSwitch -> SwitchResult
-lookForConstructor :: SimplEnv -> Id -> [UniType] -> [CoreAtom Id] -> Labda Id
-lookupId :: SimplEnv -> Id -> Labda IdVal
-lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
-mkFormSummary :: StrictnessInfo -> CoreExpr a Id -> FormSummary
-nullInEnvs :: (UniqFM UniType, UniqFM IdVal)
-nullSimplEnv :: (SimplifierSwitch -> SwitchResult) -> SimplEnv
-nullTyVarEnv :: UniqFM a
-pprSimplEnv :: SimplEnv -> Int -> Bool -> PrettyRep
-replaceInEnvs :: SimplEnv -> (UniqFM UniType, UniqFM IdVal) -> SimplEnv
-setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
-simplTy :: SimplEnv -> UniType -> UniType
-simplTyInId :: SimplEnv -> Id -> Id
-switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
-instance Eq UnfoldConApp
-instance Ord UnfoldConApp
-instance Outputable FormSummary
-instance Outputable UnfoldingGuidance
-
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[SimplEnv]{Environment stuff for the simplifier}
nullSimplEnv,
pprSimplEnv, -- debugging only
---UNUSED: getInEnvs,
replaceInEnvs, nullInEnvs,
- nullTyVarEnv,
extendTyEnv, extendTyEnvList,
simplTy, simplTyInId,
lookupId,
extendUnfoldEnvGivenRhs,
---OLD: extendUnfoldEnvWithRecInlinings,
extendUnfoldEnvGivenFormDetails,
extendUnfoldEnvGivenConstructor,
lookForConstructor,
getSwitchChecker, switchIsSet,
---UNUSED: getEnclosingCC,
setEnclosingCC,
- mkFormSummary,
-
-- Types
- SwitchChecker(..),
- SimplEnv, UnfoldingDetails(..), UnfoldingGuidance(..),
- FormSummary(..), EnclosingCcDetails(..),
+ SwitchChecker(..),
+ SimplEnv, EnclosingCcDetails(..),
InIdEnv(..), IdVal(..), InTypeEnv(..),
UnfoldEnv, UnfoldItem, UnfoldConApp,
- -- re-exported from BinderInfo
- BinderInfo(..),
- FunOrArg, DuplicationDanger, InsideSCC, -- sigh
-
- InId(..), InBinder(..), InType(..), InBinding(..), InUniType(..),
- OutId(..), OutBinder(..), OutType(..), OutBinding(..), OutUniType(..),
+ InId(..), InBinder(..), InBinding(..), InType(..),
+ OutId(..), OutBinder(..), OutBinding(..), OutType(..),
- InExpr(..), InAtom(..), InAlts(..), InDefault(..), InArg(..),
- OutExpr(..), OutAtom(..), OutAlts(..), OutDefault(..), OutArg(..),
+ InExpr(..), InAlts(..), InDefault(..), InArg(..),
+ OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..)
-- and to make the interface self-sufficient...
- BasicLit, GlobalSwitch, SimplifierSwitch, SwitchResult, CoreAtom,
- CoreCaseAlternatives, CoreExpr, Id,
- IdEnv(..), UniqFM, Unique,
- MagicUnfoldingFun, Maybe, TyVar, TyVarEnv(..), UniType
-
- IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToTy COMMA applyTypeEnvToId)
- IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA lookupUFM COMMA lookupIdEnv) -- profiling
) where
-IMPORT_Trace
+import Ubiq{-uitous-}
-import AbsUniType ( applyTypeEnvToTy, getUniDataTyCon, cmpUniType )
-import Bag ( emptyBag, Bag )
-import BasicLit ( isNoRepLit, BasicLit(..), PrimKind ) -- .. for pragmas only
-import BinderInfo
-import CmdLineOpts ( switchIsOn, intSwitchSet,
- SimplifierSwitch(..), SwitchResult
- )
-import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD )
-import CostCentre
-import FiniteMap
-import Id ( getIdUnfolding, eqId, cmpId, applyTypeEnvToId,
- getIdUniType, getIdStrictness, isWorkerId,
- isBottomingId
+import SmplLoop -- breaks the MagicUFs / SimplEnv loop
+
+import BinderInfo ( BinderInfo{-instances-} )
+import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
+import CoreSyn
+import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
+ calcUnfoldingGuidance, UnfoldingGuidance(..),
+ mkFormSummary, FormSummary
)
-import IdEnv
-import IdInfo
-import MagicUFs
-import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import OccurAnal ( occurAnalyseExpr )
-import PlainCore -- for the "Out*" types and things
-import Pretty -- debugging only
-import SimplUtils ( simplIdWantsToBeINLINEd )
-import TaggedCore -- for the "In*" types and things
-import TyVarEnv
-import UniqFM ( lookupDirectlyUFM, addToUFM_Directly, ufmToList )
-import UniqSet
-import Util
+import FiniteMap -- lots of things
+import Id ( idType, getIdUnfolding, getIdStrictness,
+ nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
+ addOneToIdEnv, modifyIdEnv,
+ IdEnv(..), IdSet(..), GenId )
+import IdInfo ( StrictnessInfo )
+import Literal ( isNoRepLit, Literal{-instances-} )
+import Outputable ( Outputable(..){-instances-} )
+import PprCore -- various instances
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType, GenTyVar )
+import Pretty
+import Type ( getAppDataTyCon )
+import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
+ growTyVarEnvList,
+ TyVarEnv(..), GenTyVar )
+import Unique ( Unique )
+import UniqSet -- lots of things
+import Usage ( UVar(..), GenUsage{-instances-} )
+import Util ( zipEqual, panic, assertPanic )
+
+type TypeEnv = TyVarEnv Type
+addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)"
+applyTypeEnvToId = panic "applyTypeEnvToId (SimplEnv)"
+applyTypeEnvToTy = panic "applyTypeEnvToTy (SimplEnv)"
+bottomIsGuaranteed = panic "bottomIsGuaranteed (SimplEnv)"
+cmpType = panic "cmpType (SimplEnv)"
+exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)"
+lookupDirectlyUFM = panic "lookupDirectlyUFM (SimplEnv)"
+manifestlyWHNF = panic "manifestlyWHNF (SimplEnv)"
+occurAnalyseExpr = panic "occurAnalyseExpr (SimplEnv)"
+oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
+oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
+simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
+uNFOLDING_CREATION_THRESHOLD = panic "uNFOLDING_CREATION_THRESHOLD (SimplEnv)"
+ufmToList = panic "ufmToList (SimplEnv)"
\end{code}
%************************************************************************
this? WDP 94/06) This allows us to neglect keeping everything paired
with its static environment.
-The environment contains bindings for all
+The environment contains bindings for all
{\em in-scope,}
{\em locally-defined}
-things.
+things.
For such things, any unfolding is found in the environment, not in the
Id. Unfoldings in the Id itself are used only for imported things
\begin{code}
data SimplEnv
- = SimplEnv
- (SwitchChecker SimplifierSwitch)
+ = SimplEnv
+ SwitchChecker
EnclosingCcDetails -- the enclosing cost-centre (when profiling)
InTypeEnv -- For cloning types
-- Domain is all in-scope type variables
-
+
InIdEnv -- IdEnv
- -- Domain is
- -- *all*
- -- *in-scope*,
- -- *locally-defined*
+ -- Domain is
+ -- *all*
+ -- *in-scope*,
+ -- *locally-defined*
-- *InIds*
-- (Could omit the exported top-level guys,
-- since their names mustn't change; and ditto
-- the non-exported top-level guys which you
-- don't want to macro-expand, since their
-- names need not change.)
- --
+ --
-- Starts off empty
-
+
UnfoldEnv -- Domain is any *OutIds*, including imports
-- where we know something more than the
-- interface file tells about their value (see
-- below)
-nullSimplEnv :: SwitchChecker SimplifierSwitch -> SimplEnv
+nullSimplEnv :: SwitchChecker -> SimplEnv
nullSimplEnv sw_chkr
= SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
pp_id_entry (v, idval)
= ppCat [ppr PprDebug v, ppStr "=>",
case idval of
- InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
- ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a]
+ InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
+ ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a]
]
pp_uf_entry (UnfoldItem v form encl_cc)
= ppCat [ppr PprDebug v, ppStr "=>",
case form of
- NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
- LiteralForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
- OtherLiteralForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") [ppr PprDebug l | l <- ls]]
- ConstructorForm c t a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
- OtherConstructorForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
- [ppr PprDebug c | c <- cs]]
- GeneralForm t w e g -> ppCat [ppStr "UF:",
- ppr PprDebug t,
- ppr PprDebug w,
+ 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,
ppr PprDebug g, ppr PprDebug e]
- MagicForm s _ -> ppCat [ppStr "Magic:", ppPStr s]
- IWantToBeINLINEd _ -> ppStr "IWantToBeINLINEd"
+ MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s]
]
\end{code}
-- If x gets an InlineIt, we must remember
-- the correct binding for y.
- | ItsAnAtom OutAtom -- Used either (a) to record the cloned Id
+ | ItsAnAtom OutArg -- Used either (a) to record the cloned Id
-- or (b) if the orig defn is a let-binding, and
-- the RHS of the let simplifies to an atom,
- -- we just bind the variable to that atom, and
+ -- we just bind the variable to that atom, and
-- elide the let.
\end{code}
%************************************************************************
%* *
-\subsubsection{The @UnfoldEnv@, @UnfoldingDetails@, and @UnfoldingGuidance@ types}
+\subsubsection{The @UnfoldEnv@ type}
%* *
%************************************************************************
-- that was in force.
data UnfoldConApp -- yet another glorified triple
- = UCA OutId -- same fields as ConstructorForm;
- [UniType] -- a new type so we can make
- [OutAtom] -- Ord work on it (instead of on
- -- UnfoldingDetails).
+ = UCA OutId -- same fields as ConForm
+ [OutArg]
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 (GeneralForm True ...)
+ -- 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
grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
grow_unfold_env (UFE u_env interesting_ids con_apps) id
- uf_details@(GeneralForm True _ _ _) encl_cc
+ 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.
= UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
where
new_con_apps
= case uf_details of
- ConstructorForm con targs vargs
+ ConForm con vargs
-> case (lookupFM con_apps entry) of
Just _ -> con_apps -- unchanged; we hang onto what we have
Nothing -> addToFM con_apps entry id
where
- entry = UCA con targs vargs
+ entry = UCA con vargs
not_a_constructor -> con_apps -- unchanged
-- otherwise, we'd need to change con_apps
UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
where
- constructor_form_in_those (_, UnfoldItem _ (ConstructorForm _ _ _) _) = True
+ constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
constructor_form_in_those _ = False
rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
Nothing -> NoEnclosingCcDetails
Just (UnfoldItem _ _ encl_cc) -> encl_cc
-lookup_conapp (UFE _ _ con_apps) con ty_args con_args
- = lookupFM con_apps (UCA con ty_args con_args)
+lookup_conapp (UFE _ _ con_apps) con args
+ = lookupFM con_apps (UCA con args)
modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
= UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
-- we modify it.
modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
-modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
+modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
= UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
\end{code}
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 }
-#ifdef __GLASGOW_HASKELL__
_tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-cmp_app (UCA c1 tys1 as1) (UCA c2 tys2 as2)
- = case cmpId c1 c2 of
+instance Ord3 UnfoldConApp where
+ cmp = cmp_app
+
+cmp_app (UCA c1 as1) (UCA c2 as2)
+ = case (c1 `cmp` c2) of
LT_ -> LT_
GT_ -> GT_
- _ -> case (cmp_lists (cmpUniType True{-properly-}) tys1 tys2) of
- LT_ -> LT_
- GT_ -> GT_
- _ -> cmp_lists cmp_atom as1 as2
+ _ -> cmp_lists cmp_atom as1 as2
where
cmp_lists cmp_item [] [] = EQ_
cmp_lists cmp_item (x:xs) [] = GT_
cmp_lists cmp_item (x:xs) (y:ys)
= case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
- cmp_atom (CoVarAtom x) (CoVarAtom y) = x `cmpId` y
- cmp_atom (CoVarAtom _) _ = LT_
- cmp_atom (CoLitAtom x) (CoLitAtom y)
-#ifdef __GLASGOW_HASKELL__
+ cmp_atom (VarArg x) (VarArg y) = x `cmp` y
+ cmp_atom (VarArg _) _ = LT_
+ cmp_atom (LitArg x) (LitArg y)
= case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
-#else
- = if x == y then EQ_ elsid if x < y then LT_ else GT_
-#endif
- cmp_atom (CoLitAtom _) _ = GT_
-\end{code}
-
-\begin{code}
-data UnfoldingDetails
- = NoUnfoldingDetails
-
- | LiteralForm
- BasicLit
-
- | OtherLiteralForm
- [BasicLit] -- It is a literal, but definitely not one of these
-
- | ConstructorForm
- Id -- The constructor
- [UniType] -- Type args
- [OutAtom] -- Value arguments; NB OutAtoms, already cloned
-
- | OtherConstructorForm
- [Id] -- It definitely isn't one of these constructors
- -- This captures the situation in the default branch of
- -- a case: case x of
- -- c1 ... -> ...
- -- c2 ... -> ...
- -- v -> default-rhs
- -- Then in default-rhs we know that v isn't c1 or c2.
- --
- -- NB. In the degenerate: case x of {v -> default-rhs}
- -- x will be bound to
- -- OtherConstructorForm []
- -- which captures the idea that x is eval'd but we don't
- -- know which constructor.
-
-
- | GeneralForm
- 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.
-
- | MagicForm
- FAST_STRING
- MagicUnfoldingFun
-
- {-OLD? Nukable? ("Also turgid" SLPJ)-}
- | IWantToBeINLINEd -- Means this has an INLINE pragma;
- -- Used for things which have a defn in this module
- UnfoldingGuidance -- Guidance from the pragma; usually UnfoldAlways.
-
-data FormSummary
- = WhnfForm -- Expression is WHNF
- | BottomForm -- Expression is guaranteed to be bottom. We're more gung
- -- ho about inlining such things, because it can't waste work
- | OtherForm -- Anything else
-
-instance Outputable FormSummary where
- ppr sty WhnfForm = ppStr "WHNF"
- ppr sty BottomForm = ppStr "Bot"
- ppr sty OtherForm = ppStr "Other"
-
-mkFormSummary :: StrictnessInfo -> CoreExpr bndr Id -> FormSummary
-mkFormSummary si expr
- | manifestlyWHNF expr = WhnfForm
- | bottomIsGuaranteed si = BottomForm
-
- -- Chances are that the Id will be decorated with strictness info
- -- telling that the RHS is definitely bottom. This *might* not be the
- -- case, if it's been a while since strictness analysis, but leaving out
- -- the test for manifestlyBottom makes things a little more efficient.
- -- We can always put it back...
- -- | manifestlyBottom expr = BottomForm
-
- | otherwise = OtherForm
-\end{code}
-
-\begin{code}
-data UnfoldingGuidance
- = UnfoldNever -- Don't do it!
-
- | UnfoldAlways -- There is no "original" definition,
- -- so you'd better unfold. Or: something
- -- so cheap to unfold (e.g., 1#) that
- -- you should do it absolutely always.
-
- | EssentialUnfolding -- Like UnfoldAlways, but you *must* do
- -- it absolutely always.
- -- This is what we use for data constructors
- -- and PrimOps, because we don't feel like
- -- generating curried versions "just in case".
-
- | UnfoldIfGoodArgs Int -- if "m" type args and "n" value args; and
- Int -- those val args are manifestly data constructors
- [Bool] -- the val-arg positions marked True
- -- (i.e., a simplification will definitely
- -- be possible).
- Int -- The "size" of the unfolding; to be elaborated
- -- later. ToDo
-
- | BadUnfolding -- This is used by TcPragmas if the *lazy*
- -- lintUnfolding test fails
- -- It will never escape from the IdInfo as
- -- it is caught by getInfo_UF and converted
- -- to NoUnfoldingDetails
-\end{code}
-
-\begin{code}
-instance Outputable UnfoldingGuidance where
- ppr sty UnfoldNever = ppStr "_N_"
- ppr sty UnfoldAlways = ppStr "_ALWAYS_"
- ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
- ppr sty (UnfoldIfGoodArgs t v cs size)
- = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
- if null cs -- always print *something*
- then ppChar 'X'
- else ppBesides (map pp_c cs),
- ppInt size ]
- where
- pp_c False = ppChar 'X'
- pp_c True = ppChar 'C'
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
-%* *
-%************************************************************************
-
-\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
- -> TemplateOutExpr -- Template
- -> UnfoldingGuidance -- Tells about the *size* of the template.
- -> UnfoldingDetails
-
-mkGenForm safe_to_dup occ_info WhnfForm template guidance
- = GeneralForm (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
- = GeneralForm True form_summary template guidance
-
- | otherwise -- Not a WHNF, many occurrences
- = NoUnfoldingDetails
-\end{code}
-
-\begin{code}
-modifyUnfoldingDetails
- :: Bool -- OK to dup
- -> BinderInfo -- New occurrence info for the thing
- -> UnfoldingDetails
- -> UnfoldingDetails
-
-modifyUnfoldingDetails ok_to_dup occ_info
- (GeneralForm only_one form_summary template guidance)
- | only_one = mkGenForm ok_to_dup occ_info form_summary template guidance
-
-{- OLD:
- | otherwise = NoUnfoldingDetails
- I can't see why we zap bindings which don't claim to be unique
--}
-
-modifyUnfoldingDetails ok_to_dup occ_info other = other
+ cmp_atom (LitArg _) _ = GT_
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-type InId = Id -- Not yet cloned
-type InBinder = (InId, BinderInfo)
-type InType = UniType -- Ditto
+type InId = Id -- Not yet cloned
+type InBinder = (InId, BinderInfo)
+type InType = Type -- Ditto
type InBinding = SimplifiableCoreBinding
type InExpr = SimplifiableCoreExpr
-type InAtom = SimplifiableCoreAtom -- same as PlainCoreAtom
-type InAlts = SimplifiableCoreCaseAlternatives
+type InAlts = SimplifiableCoreCaseAlts
type InDefault = SimplifiableCoreCaseDefault
-type InArg = CoreArg InId
-type InUniType = UniType
+type InArg = SimplifiableCoreArg
-type OutId = Id -- Cloned
+type OutId = Id -- Cloned
type OutBinder = Id
-type OutType = UniType -- Cloned
-type OutBinding = PlainCoreBinding
-type OutExpr = PlainCoreExpr
-type OutAtom = PlainCoreAtom
-type OutAlts = PlainCoreCaseAlternatives
-type OutDefault = PlainCoreCaseDefault
-type OutArg = CoreArg OutId
-type OutUniType = UniType
-
-type TemplateOutExpr = CoreExpr (OutId, BinderInfo) OutId
- -- An OutExpr with occurrence info attached
- -- This is used as a template in GeneralForms.
+type OutType = Type -- Cloned
+type OutBinding = CoreBinding
+type OutExpr = CoreExpr
+type OutAlts = CoreCaseAlts
+type OutDefault = CoreCaseDefault
+type OutArg = CoreArg
+
\end{code}
\begin{code}
-type SwitchChecker switch = switch -> SwitchResult
+type SwitchChecker = SimplifierSwitch -> SwitchResult
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-getSwitchChecker :: SimplEnv -> SwitchChecker SimplifierSwitch
+getSwitchChecker :: SimplEnv -> SwitchChecker
getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
%************************************************************************
\begin{code}
--- UNUSED:
---getEnclosingCC :: SimplEnv -> EnclosingCcDetails
---getEnclosingCC (SimplEnv _ encl_cc _ _ _) = encl_cc
-
setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
%************************************************************************
\begin{code}
-type InTypeEnv = TypeEnv -- Maps InTyVars to OutUniTypes
+type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
-extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv
+extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
= SimplEnv chkr encl_cc new_ty_env id_env unfold_env
where
new_ty_env = addOneToTyVarEnv ty_env tyvar ty
-extendTyEnvList :: SimplEnv -> [(TyVar,UniType)] -> SimplEnv
+extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
= SimplEnv chkr encl_cc new_ty_env id_env unfold_env
where
simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
\end{code}
-@replaceInEnvs@ is used to install saved type and id envs
+@replaceInEnvs@ is used to install saved type and id envs
when pulling an un-simplified expression out of the environment, which
was saved with its environments.
\begin{code}
nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
--- UNUSED:
---getInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv)
---getInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) = (ty_env,id_env)
-
replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
-replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
+
+replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
(new_ty_env, new_id_env)
- = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
+ = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
\end{code}
%************************************************************************
\begin{code}
extendIdEnvWithAtom
:: SimplEnv
- -> InBinder -> OutAtom
+ -> InBinder -> OutArg
-> SimplEnv
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(CoLitAtom 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@(CoVarAtom out_id)
+ (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)
extendIdEnvWithAtomList
:: SimplEnv
- -> [(InBinder, OutAtom)]
+ -> [(InBinder, OutArg)]
-> SimplEnv
extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
-> InBinder -> InExpr
-> SimplEnv
-extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- ~(SimplEnv _ _ inline_ty_env inline_id_env _ )
- (in_id,occ_info)
+extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env)
+ ~(SimplEnv _ _ inline_ty_env inline_id_env _ )
+ (in_id,occ_info)
expr
= SimplEnv chkr encl_cc ty_env new_id_env unfold_env
where
-> SimplEnv
extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (in_id,_) out_id
+ (in_id,_) out_id
= SimplEnv chkr encl_cc ty_env new_id_env unfold_env
where
- new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (CoVarAtom out_id))
+ new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
extendIdEnvWithClones -- Like extendIdEnvWithClone
:: SimplEnv
where
new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
in_ids = [id | (id,_) <- in_binders]
- out_vals = [ItsAnAtom (CoVarAtom out_id) | out_id <- out_ids]
+ out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
lookupId :: SimplEnv -> Id -> Maybe IdVal
extendUnfoldEnvGivenConstructor env var con args
= let
-- conjure up the types to which the con should be applied
- scrut_ty = getIdUniType var
- (_, ty_args, _) = getUniDataTyCon scrut_ty
+ scrut_ty = idType var
+ (_, ty_args, _) = getAppDataTyCon scrut_ty
in
extendUnfoldEnvGivenFormDetails
- env var (ConstructorForm con ty_args (map CoVarAtom args))
+ env var (ConForm con (map VarArg args))
\end{code}
-@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
+@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
of a new binding. There is a horrid case we have to take care about,
due to Andr\'e Santos:
@
tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
f_iaamain a_xs=
- let {
- f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
- f_aareorder a_index a_ar=
- let {
- f_aareorder' a_i= a_ar ! (a_index ! a_i)
- } in tabulate f_aareorder' (bounds a_ar);
- r_index=tabulate ((+) 1) (1,1);
+ let {
+ f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
+ f_aareorder a_index a_ar=
+ let {
+ f_aareorder' a_i= a_ar ! (a_index ! a_i)
+ } in tabulate f_aareorder' (bounds a_ar);
+ r_index=tabulate ((+) 1) (1,1);
arr = listArray (1,1) a_xs;
arg = f_aareorder r_index arr
- } in elems arg
+ } in elems arg
@
Now, when the RHS of arg gets simplified, we inline f_aareorder to get
@
- arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
+ arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
in tabulate f_aareorder' (bounds arr)
@
Note that r_index is not inlined, because it was bound to a_index which
-- Compute unfolding details
details = case rhs of
- CoVar v -> panic "CoVars already dealt with"
- CoLit lit | isNoRepLit lit -> LiteralForm lit
- | otherwise -> panic "non-noRep CoLits already dealt with"
+ Var v -> panic "Vars already dealt with"
+ Lit lit | isNoRepLit lit -> LitForm lit
+ | otherwise -> panic "non-noRep Lits already dealt with"
- CoCon con tys args -> ConstructorForm con tys args
+ Con con args -> ConForm con args
other -> mkGenForm ok_to_dup occ_info
(mkFormSummary (getIdStrictness out_id) rhs)
-- Compute resulting unfold env
new_unfold_env = case details of
NoUnfoldingDetails -> unfold_env
- GeneralForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
+ GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
other -> unfold_env1
-- Add unfolding to unfold env
Nothing -> uNFOLDING_CREATION_THRESHOLD
Just xx -> xx
- ok_to_dup = switchIsOn chkr SimplOkToDupCode
+ ok_to_dup = switchIsOn chkr SimplOkToDupCode
|| exprSmallEnoughToDup rhs
-- [Andy] added, Jun 95
-- False -> g x
-}
{- OLD:
- Omitted SLPJ Feb 95; should, I claim, be unnecessary
+ Omitted SLPJ Feb 95; should, I claim, be unnecessary
-- is_really_small looks for things like f a b c
-- but making sure there are not *too* many arguments.
-- (This is brought to you by *ANDY* Magic Constants, Inc.)
is_really_small
= case collectArgs new_rhs of
- (CoVar _, xs) -> length xs < 10
+ (Var _, xs) -> length xs < 10
_ -> False
-}
-
-
-{- UNUSED:
-extendUnfoldEnvWithRecInlinings :: SimplEnv -> [OutId] -> [InExpr] -> SimplEnv
-
-extendUnfoldEnvWithRecInlinings env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
- new_ids old_rhss
- = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
- where
- extra_unfold_items
- = [ (new_id, UnfoldItem new_id
- (GeneralForm True
- (mkFormSummary (getIdStrictness new_id) old_rhs)
- old_rhs UnfoldAlways)
- encl_cc)
- | (new_id, old_rhs) <- new_ids `zipEqual` old_rhss,
- simplIdWantsToBeINLINEd new_id env
- ]
-
- new_unfold_env = addto_unfold_env unfold_env extra_unfold_items
--}
\end{code}
\begin{code}
| not (isLocallyDefined var) -- Imported, so look inside the id
= getIdUnfolding var
- | otherwise -- Locally defined, so look in the envt.
+ | otherwise -- Locally defined, so look in the envt.
-- There'll be nothing inside the Id.
= lookup_unfold_env unfold_env var
\end{code}
-We need to remove any @GeneralForm@ bindings from the UnfoldEnv for
+We need to remove any @GenForm@ bindings from the UnfoldEnv for
the RHS of an Id which has an INLINE pragma.
\begin{code}
-- be inlined wherever they are used, and then all the
-- UnfoldEnv stuff will take effect. Meanwhile, there isn't
-- much point in doing anything to the as-yet-un-INLINEd rhs.
-
+
-- Andy disagrees! Example:
-- all xs = foldr (&&) True xs
-- any p = all . map p {-# INLINE any #-}
- --
- -- Problem: any won't get deforested, and so if it's exported and
+ --
+ -- Problem: any won't get deforested, and so if it's exported and
-- the importer doesn't use the inlining, (eg passes it as an arg)
-- then we won't get deforestation at all.
- --
+ --
-- So he'd like not to filter the unfold env at all. But that's a disaster:
-- Suppose we have:
--
-- let f = \pq -> BIG
- -- in
+ -- in
-- let g = \y -> f y y
-- {-# INLINE g #-}
-- in ...g...g...g...g...g...
- --
+ --
-- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
- -- and thence copied multiple times when g is inlined.
+ -- and thence copied multiple times when g is inlined.
\end{code}
======================
\begin{verbatim}
= -- Don't re-use nullary constructors; it's a waste. Consider
- -- let
+ -- let
-- a = leInt#! p q
- -- in
+ -- in
-- case a of
-- True -> ...
-- False -> False
case isn't necessary any more.
\begin{code}
-lookForConstructor (SimplEnv _ _ _ _ unfold_env) con ty_args con_args
- = lookup_conapp unfold_env con ty_args con_args
+lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
+ = lookup_conapp unfold_env con args
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[SimplHaskell]{Printing Core that looks like Haskell}
-
-\begin{code}
-#include "HsVersions.h"
-
-module SimplHaskell ( coreToHaskell ) where
-
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import BasicLit ( BasicLit )
-import PlainCore
-import IdEnv
-import IdInfo
-import Maybes
-import Util
-import AbsPrel ( PrimOp, nilDataCon, consDataCon )
-\end{code}
-
-\begin{code}
-coreToHaskell :: PlainCoreProgram -> String {- 0 -}
-coreToHaskell binds = ("[Haskell:\n\n" ++ ppShow 80 (pprHaskFuns (transformCoreProg binds)) ++ "\n\n]\n")
-\end{code}
-
-\begin{code}
-data HaskFun = HaskFun Id [([HaskExp],HaskExp)]
-
-data HaskExp
- = HaskVar Bool Id -- true of used many times
- | HaskLit BasicLit
- | HaskWild
- | HaskCon Id [HaskExp]
- | HaskPrim PrimOp [HaskExp]
- | HaskLam [HaskExp] HaskExp
- | HaskApp HaskExp HaskExp
- | HaskCase HaskExp [(HaskExp,HaskExp)]
- | HaskIf HaskExp HaskExp HaskExp
- | HaskLet [HaskFun] HaskExp
-\end{code}
-
-Here is where the fun begins, you transform Core into Haskell!
-
-\begin{code}
-type InEnv = IdEnv HaskExp
-type OutEnv = IdEnv (Int,Bool) -- number of times used, and if save to inline
-
-
-mkHaskPatVar :: OutEnv -> Id -> HaskExp
-mkHaskPatVar env id = case lookupIdEnv env id of
- Nothing -> HaskWild
- Just (n,_) -> HaskVar (n > 1) id
-
-transformCoreProg :: PlainCoreProgram -> [HaskFun]
-transformCoreProg prog = mergeCasesBindings funs
- where
- (_,_,funs) = transformCoreBindings nullIdEnv nullIdEnv prog
-
-transformCoreBindings :: InEnv -> OutEnv -> [PlainCoreBinding] -> (InEnv,OutEnv,[HaskFun])
-transformCoreBindings in_env out_env [bnd] = transformCoreBinding in_env out_env bnd
-transformCoreBindings in_env out_env (bnd:bnds) = (in_env'',out_env',hask_bnd ++ hask_bnds)
- where
- (in_env',out_env',hask_bnd) = transformCoreBinding in_env out_env'' bnd
- (in_env'',out_env'',hask_bnds) = transformCoreBindings in_env' out_env bnds
-
-transformCoreBinding :: InEnv -> OutEnv -> PlainCoreBinding -> (InEnv,OutEnv,[HaskFun])
-transformCoreBinding in_env out_env (CoNonRec v expr) = (in_env',out_env'',[HaskFun v rhs])
- where
- out_env'' = merge out_env out_env'
- (out_env',rhs) = transformCoreRhs in_env expr
- in_env' = in_env `growIdEnvList` [ (v,exp) | [([],exp)] <- [rhs], False ]
-
-transformCoreBinding in_env out_env (CoRec bnds) = (in_env,out_env'',hask_bnds)
- where
- out_env'' = foldl merge out_env out_envs
- (out_envs,hask_bnds) = unzip
- [ (out_env',HaskFun v rhs) |
- (v,exp) <- bnds,
- (out_env',rhs) <- [transformCoreRhs in_env exp]]
-
-
-transformCoreRhs :: InEnv -> PlainCoreExpr -> (OutEnv,[([HaskExp],HaskExp)])
-transformCoreRhs in_env exp = (out_env,[(vars',hask_exp)])
- where
- vars' = [ mkHaskPatVar out_env v | v <- vars ]
- (vars,exp') = getLambdaVars exp
- (out_env,hask_exp) = transformCoreExp in_env exp'
- getLambdaVars (CoTyLam _ e) = getLambdaVars e
- getLambdaVars (CoLam xs e) = (xs ++ xs',e')
- where (xs',e') = getLambdaVars e
- getLambdaVars e = ([],e)
-
-transformCoreExp :: InEnv -> PlainCoreExpr -> (OutEnv,HaskExp)
-transformCoreExp _ (CoVar v) = (unitIdEnv v (1,True),HaskVar False v) -- lookup Env ?
-transformCoreExp _ (CoLit i) = (nullIdEnv,HaskLit i)
-transformCoreExp in_env (CoCon i _ atoms) = (out_env,HaskCon i hask_exps)
- where
- (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms)
-transformCoreExp in_env (CoPrim i _ atoms) = (out_env,HaskPrim i hask_exps)
- where
- (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms)
--- CoLam
--- CoTyLam
-transformCoreExp in_env (CoLam args exp) = (out_env,HaskLam args' h_exp)
- where -- modify the env !!!!!
- args' = [ mkHaskPatVar out_env v | v <- args ]
- (out_env,h_exp) = transformCoreExp in_env exp
-transformCoreExp in_env (CoTyLam _ exp) = transformCoreExp in_env exp
-transformCoreExp in_env (CoApp fun atom) = (merge o1 o2,HaskApp h_fun h_arg)
- where
- (o1,h_fun) = transformCoreExp in_env fun
- (o2,h_arg) = transformCoreExp in_env (atomToExpr atom)
-transformCoreExp in_env (CoTyApp fun _) = transformCoreExp in_env fun
-transformCoreExp in_env (CoCase e alts) = (foldl merge o1 o2,HaskCase h_e h_alts)
- where
- (o1,h_e) = transformCoreExp in_env e
- (o2,h_alts) = unzip [ (out_env,(pat,h_e)) | (out_env,pat,h_e) <- transformCoreAlts in_env alts ]
-
-transformCoreExp in_env exp@(CoLet _ _) = (o1,HaskLet h_binds h_exp)
- where
- (binds,exp') = getLets exp
- (in_env',o1,h_binds) = transformCoreBindings in_env o2 binds
- (o2,h_exp) = transformCoreExp in_env' exp'
- getLets (CoLet bind exp) = (bind:binds,exp')
- where (binds,exp') = getLets exp
- getLets exp = ([],exp)
-
-transformCoreExp _ _ = (nullIdEnv,HaskWild)
-
-transformCoreExps :: InEnv -> [PlainCoreExpr] -> (OutEnv,[HaskExp])
-transformCoreExps _ [] = (nullIdEnv,[])
-transformCoreExps in_env (e:es) = (merge o1 o2,h_e:hs_e)
- where
- (o1,h_e) = transformCoreExp in_env e
- (o2,hs_e) = transformCoreExps in_env es
-
-transformCoreAlts :: InEnv -> PlainCoreCaseAlternatives -> [(OutEnv,HaskExp,HaskExp)]
-transformCoreAlts in_env (CoAlgAlts alts def) = map trans alts ++ mkdef def
- where
- trans (id,ids,e) = (o1,HaskCon id (map (mkHaskPatVar o1) ids),h_e)
- where
- (o1,h_e) = transformCoreExp in_env e
- mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)]
- where
- (o1,h_e) = transformCoreExp in_env e
- mkdef _ = []
-transformCoreAlts in_env (CoPrimAlts alts def) = map trans alts ++ mkdef def
- where
- trans (lit,e) = (o1,HaskLit lit,h_e)
- where
- (o1,h_e) = transformCoreExp in_env e
- mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)]
- where
- (o1,h_e) = transformCoreExp in_env e
- mkdef _ = []
-\end{code}
-
-\begin{code}
-merge :: OutEnv -> OutEnv -> OutEnv
-merge e1 e2 = combineIdEnvs fn e1 e2
- where
- fn (n,_) (m,_) = (n+m,False)
-\end{code}
-
-
-\begin{code}
-mergeCasesBindings = map mergeCasesFun
-
-mergeCasesFun (HaskFun id rhss) = HaskFun id (concat (map mergeCasesRhs rhss))
-
-mergeCasesRhs (pats,exp) = [(pats,exp)]
-
-{-
-case v of
- A x -> e1 , v ==> Branch v [ (A x,e1), (B y,e2) ]
- B y -> e2 OR
- NoBranches (case v of
- A x -> ...
- B y -> ...)
-
--}
---mergeCases :: HaskExp -> Set Id -> [(Id,HaskExp,HaskExp)]
---mergeCases _ _ = []
-\end{code}
-
-
-
-Maybe ???
-
-type SM a = OutEnv Z
-returnSH a s = (a,s)
-thenSH m k s = case m s of
- (r,s') -> k r s
-thenSH_ m k s = case m s of
- (_,s') -> k s
-
-\begin{code}
-pprHaskFuns xs = ppAboves (map pprHaskFun xs)
-
-pprHaskFun (HaskFun id stuff) =
- ppAboves [
- ppSep [ ppCat ([ppr PprForUser id] ++ map (pprHaskExp True) pats),
- ppNest 2 (ppCat [ppStr "=",pprHaskExp False rhs])]
- | (pats,rhs) <- stuff]
-
-pprHaskExp :: Bool -> HaskExp -> Pretty
-pprHaskExp _ (HaskVar _ id) = ppr PprForUser id
-pprHaskExp _ (HaskLit i) = ppr PprForUser i
-pprHaskExp _ (HaskWild) = ppStr "_"
-pprHaskExp True exp = ppBesides [ppLparen,pprHaskExp False exp,ppRparen]
-pprHaskExp _ (HaskCon con []) | con == nilDataCon = ppStr "[]"
-pprHaskExp _ (HaskCon con [e1,e2]) | con == consDataCon =
- ppCat [pprHaskExp True e1,ppStr ":",pprHaskExp True e2]
-pprHaskExp _ (HaskCon con exps) =
- ppCat (ppr PprForUser con:map (pprHaskExp True) exps)
-pprHaskExp _ (HaskPrim prim exps) =
- ppCat (ppr PprForUser prim:map (pprHaskExp True) exps)
-pprHaskExp _ app@(HaskLam xs e) = -- \ xs -> e
- ppSep [ ppCat ([ppStr "\\"] ++ map (pprHaskExp True) xs),
- ppNest 2 (ppCat [ppStr "->",pprHaskExp False e])]
-pprHaskExp _ app@(HaskApp _ _) = pprHaskApp app
-pprHaskExp _ (HaskCase e opts)
- = ppAboves [ppCat [ppStr "case", pprHaskExp False e,ppStr "of"],
- ppNest 2 (
- ppAboves [
- (ppSep [ppCat [pprHaskExp False pat,ppStr "->"],
- ppNest 2 (pprHaskExp False exp)])
- | (pat,exp) <- opts])]
-pprHaskExp _ (HaskIf i t e) = ppAboves
- [ppCat [ppStr "if",pprHaskExp False i],
- ppCat [ppStr "then",pprHaskExp False t],
- ppCat [ppStr "else",pprHaskExp False e]]
-pprHaskExp _ (HaskLet binds e)
- = ppAboves [ppStr "let",
- ppNest 2 (pprHaskFuns binds),
- ppCat [ppStr "in",ppNest 1 (pprHaskExp False e)]]
-pprHaskExp _ _ = panic "pprHaskExp failed"
-
-
-pprHaskApp (HaskApp fun arg) = ppCat [pprHaskApp fun,pprHaskExp True arg]
-pprHaskApp e = pprHaskExp True e
-\end{code}
-
-
-
-pprHaskExp n exp = ppr
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplMonad where
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PrimOps(PrimOp)
-import SimplEnv(SimplEnv)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-infixr 9 `thenSmpl`
-infixr 9 `thenSmpl_`
-data BinderInfo
-data CoreExpr a b
-data Id
-data PrimOp
-data SimplCount
-type SmplM a = SplitUniqSupply -> SimplCount -> (a, SimplCount)
-data SplitUniqSupply
-data TickType = UnfoldingDone | MagicUnfold | ConReused | CaseFloatFromLet | CaseOfCase | LetFloatFromLet | LetFloatFromCase | KnownBranch | Let2Case | CaseMerge | CaseElim | CaseIdentity | AtomicRhs | EtaExpansion | CaseOfError | TyBetaReduction | BetaReduction | FoldrBuild | FoldrAugment | Foldr_Nil | Foldr_List | FoldlBuild | FoldlAugment | Foldl_Nil | Foldl_List | Foldr_Cons_Nil | Foldr_Cons | Str_FoldrStr | Str_UnpackCons | Str_UnpackNil
-data TyVar
-data UniType
-cloneId :: SimplEnv -> (Id, BinderInfo) -> SplitUniqSupply -> SimplCount -> (Id, SimplCount)
-cloneIds :: SimplEnv -> [(Id, BinderInfo)] -> SplitUniqSupply -> SimplCount -> ([Id], SimplCount)
-cloneTyVarSmpl :: TyVar -> SplitUniqSupply -> SimplCount -> (TyVar, SimplCount)
-combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
-detailedSimplCount :: SplitUniqSupply -> SimplCount -> (SimplCount, SimplCount)
-initSmpl :: SplitUniqSupply -> (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (a, SimplCount)
-mapAndUnzipSmpl :: (a -> SplitUniqSupply -> SimplCount -> ((b, c), SimplCount)) -> [a] -> SplitUniqSupply -> SimplCount -> (([b], [c]), SimplCount)
-mapSmpl :: (a -> SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> [a] -> SplitUniqSupply -> SimplCount -> ([b], SimplCount)
-newId :: UniType -> SplitUniqSupply -> SimplCount -> (Id, SimplCount)
-newIds :: [UniType] -> SplitUniqSupply -> SimplCount -> ([Id], SimplCount)
-returnSmpl :: a -> SplitUniqSupply -> SimplCount -> (a, SimplCount)
-showSimplCount :: SimplCount -> [Char]
-simplCount :: SplitUniqSupply -> SimplCount -> (Int, SimplCount)
-thenSmpl :: (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (a -> SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> SplitUniqSupply -> SimplCount -> (b, SimplCount)
-thenSmpl_ :: (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> SplitUniqSupply -> SimplCount -> (b, SimplCount)
-tick :: TickType -> SplitUniqSupply -> SimplCount -> ((), SimplCount)
-tickN :: TickType -> Int -> SplitUniqSupply -> SimplCount -> ((), SimplCount)
-zeroSimplCount :: SimplCount
-instance Eq TickType
-instance Ix TickType
-instance Ord TickType
-instance Text TickType
-
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[SimplMonad]{The simplifier Monad}
SmplM(..),
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl,
-
+
-- Counting
SimplCount{-abstract-}, TickType(..), tick, tickN,
simplCount, detailedSimplCount,
zeroSimplCount, showSimplCount, combineSimplCounts,
-- Cloning
- cloneId, cloneIds, cloneTyVarSmpl, newIds, newId,
+ cloneId, cloneIds, cloneTyVarSmpl, newIds, newId
-- and to make the interface self-sufficient...
- BinderInfo, CoreExpr, Id, PrimOp, TyVar, UniType,
- SplitUniqSupply
-
- IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
) where
-IMPORT_Trace -- ToDo: rm (debugging)
+import Ubiq{-uitous-}
-import TaggedCore
-import PlainCore
+import SmplLoop -- well, cheating sort of
-import AbsUniType ( cloneTyVar )
-import CmdLineOpts
-import Id ( mkIdWithNewUniq, mkSysLocal )
-import IdInfo
+import Id ( mkSysLocal )
import SimplEnv
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import SplitUniq
-import Unique
-import Util
+import SrcLoc ( mkUnknownSrcLoc )
+import UniqSupply ( getUnique, getUniques, splitUniqSupply,
+ UniqSupply
+ )
+import Util ( zipWithEqual, panic )
infixr 9 `thenSmpl`, `thenSmpl_`
+
+cloneTyVar = panic "cloneTyVar (SimplMonad)"
+mkIdWithNewUniq = panic "mkIdWithNewUniq (SimplMonad)"
\end{code}
%************************************************************************
%* *
-\subsection[Monad]{Monad plumbing}
+\subsection{Monad plumbing}
%* *
%************************************************************************
\begin{code}
type SmplM result
- = SplitUniqSupply
+ = UniqSupply
-> SimplCount -- things being threaded
-> (result, SimplCount)
\end{code}
\begin{code}
-initSmpl :: SplitUniqSupply -- no init count; set to 0
+initSmpl :: UniqSupply -- no init count; set to 0
-> SmplM a
-> (a, SimplCount)
initSmpl us m = m us zeroSimplCount
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenSmpl #-}
{-# INLINE thenSmpl_ #-}
{-# INLINE returnSmpl #-}
-#endif
returnSmpl :: a -> SmplM a
returnSmpl e us sc = (e, sc)
%************************************************************************
%* *
-\subsection[SimplCount]{Counting up what we've done}
+\subsection{Counting up what we've done}
%* *
%************************************************************************
| BetaReduction
{- BEGIN F/B ENTRIES -}
-- the 8 rules
- | FoldrBuild -- foldr f z (build g) ==>
- | FoldrAugment -- foldr f z (augment g z) ==>
- | Foldr_Nil -- foldr f z [] ==>
- | Foldr_List -- foldr f z (x:...) ==>
+ | FoldrBuild -- foldr f z (build g) ==>
+ | FoldrAugment -- foldr f z (augment g z) ==>
+ | Foldr_Nil -- foldr f z [] ==>
+ | Foldr_List -- foldr f z (x:...) ==>
- | FoldlBuild -- foldl f z (build g) ==>
- | FoldlAugment -- foldl f z (augment g z) ==>
- | Foldl_Nil -- foldl f z [] ==>
- | Foldl_List -- foldl f z (x:...) ==>
+ | FoldlBuild -- foldl f z (build g) ==>
+ | FoldlAugment -- foldl f z (augment g z) ==>
+ | Foldl_Nil -- foldl f z [] ==>
+ | Foldl_List -- foldl f z (x:...) ==>
| Foldr_Cons_Nil -- foldr (:) [] => id
| Foldr_Cons -- foldr (:) => flip (++)
(Foldr_Cons_Nil, 0),
(Foldr_Cons, 0),
- (Str_FoldrStr, 0),
- (Str_UnpackCons, 0),
- (Str_UnpackNil, 0) ]
+ (Str_FoldrStr, 0),
+ (Str_UnpackCons, 0),
+ (Str_UnpackNil, 0) ]
--
---= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
+--= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline)
-- [ i := 0 | i <- indices zeroSimplCount ]
\end{code}
incd = cnt + 1
in
(ttype, incd) : xs
- else
+ else
x : inc_tick xs
tickN :: TickType -> Int -> SmplM ()
incd = cnt + IBOX(increment)
in
(ttype, incd) : xs
- else
+ else
x : inc_tick xs
simplCount :: SmplM Int
#else
combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2)
= SimplCount (n1 _ADD_ n2)
- (zipWith (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
+ (zipWithEqual (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2)
#endif
\end{code}
%************************************************************************
\begin{code}
-newId :: UniType -> SmplM Id
+newId :: Type -> SmplM Id
newId ty us sc
= (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
where
- uniq = getSUnique us
+ uniq = getUnique us
-newIds :: [UniType] -> SmplM [Id]
+newIds :: [Type] -> SmplM [Id]
newIds tys us sc
- = (zipWith mk_id tys uniqs, sc)
+ = (zipWithEqual mk_id tys uniqs, sc)
where
- uniqs = getSUniques (length tys) us
+ uniqs = getUniques (length tys) us
mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
cloneTyVarSmpl :: TyVar -> SmplM TyVar
cloneTyVarSmpl tyvar us sc
= (new_tyvar, sc)
where
- uniq = getSUnique us
+ uniq = getUnique us
new_tyvar = cloneTyVar tyvar uniq
cloneId :: SimplEnv -> InBinder -> SmplM OutId
= (mkIdWithNewUniq id_with_new_ty uniq, sc)
where
id_with_new_ty = simplTyInId env id
- uniq = getSUnique us
+ uniq = getUnique us
cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId]
cloneIds env binders = mapSmpl (cloneId env) binders
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplPgm where
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-simplifyPgm :: [CoreBinding Id Id] -> (GlobalSwitch -> SwitchResult) -> (SimplifierSwitch -> SwitchResult) -> SimplCount -> SplitUniqSupply -> ([CoreBinding Id Id], Int, SimplCount)
-
module SimplPgm ( simplifyPgm ) where
-import PlainCore
-import TaggedCore
-
-import Pretty -- ToDo: rm debugging
-IMPORT_Trace
-
-import AbsUniType ( getTyVarMaybe )
+import Type ( getTyVarMaybe )
import CmdLineOpts ( switchIsOn, intSwitchSet,
GlobalSwitch(..), SimplifierSwitch(..)
)
-import Id ( cmpId, externallyVisibleId )
-import IdEnv
+import Id ( externallyVisibleId )
import IdInfo
import Maybes ( catMaybes, Maybe(..) )
import Outputable
import SimplMonad
import Simplify ( simplTopBinds )
import OccurAnal -- occurAnalyseBinds
-#if ! OMIT_FOLDR_BUILD
-import NewOccurAnal -- newOccurAnalyseBinds
-#endif
-import TyVarEnv -- ( nullTyVarEnv )
-import SplitUniq
-import Unique
+import UniqSupply
import Util
\end{code}
\begin{code}
-simplifyPgm :: [PlainCoreBinding] -- input
+simplifyPgm :: [CoreBinding] -- input
-> (GlobalSwitch->SwitchResult) -- switch lookup fns (global
-> (SimplifierSwitch->SwitchResult) -- and this-simplification-specific)
-> SimplCount -- info about how many times
-- each transformation has occurred
- -> SplitUniqSupply
- -> ([PlainCoreBinding], -- output
+ -> UniqSupply
+ -> ([CoreBinding], -- output
Int, -- info about how much happened
SimplCount) -- accumulated simpl stats
global_switch_is_on = switchIsOn g_sw_chkr
simpl_switch_is_on = switchIsOn s_sw_chkr
-#if OMIT_FOLDR_BUILD
occur_anal = occurAnalyseBinds
-#else
- occur_anal = if simpl_switch_is_on SimplDoNewOccurAnal
- then newOccurAnalyseBinds
- else occurAnalyseBinds
-#endif
max_simpl_iterations
= case (intSwitchSet s_sw_chkr MaxSimplifierIterations) of
Nothing -> 1 -- default
Just max -> max
- simpl_pgm :: Int -> Int -> [PlainCoreBinding] -> SmplM ([PlainCoreBinding], Int, SimplCount)
+ simpl_pgm :: Int -> Int -> [CoreBinding] -> SmplM ([CoreBinding], Int, SimplCount)
simpl_pgm n iterations pgm
= -- find out what top-level binders are used,
(let stop_now = r == n {-nothing happened-}
|| (if iterations > max_simpl_iterations then
(if max_simpl_iterations > 1 {-otherwise too boring-} then
- trace
+ trace
("NOTE: Simplifier still going after "++show max_simpl_iterations++" iterations; bailing out.")
else id)
True
- else
+ else
False)
in
if stop_now then
not_elem = isn'tIn "undup"
-tidy_top :: [PlainCoreBinding] -> SUniqSM [PlainCoreBinding]
+tidy_top :: [CoreBinding] -> UniqSM [CoreBinding]
tidy_top binds_in
= if null blast_alist then
- returnSUs binds_in -- no joy there
+ returnUs binds_in -- no joy there
else
-- pprTrace "undup output length:" (ppInt (length blast_alist)) (
- mapSUs blast binds_in `thenSUs` \ binds_maybe ->
- returnSUs (catMaybes binds_maybe)
+ mapUs blast binds_in `thenUs` \ binds_maybe ->
+ returnUs (catMaybes binds_maybe)
-- )
where
blast_alist = undup (foldl find_cand [] binds_in)
blast_id_env = mkIdEnv blast_alist
- blast_val_env= mkIdEnv [ (l, CoVar e) | (l,e) <- blast_alist ]
+ blast_val_env= mkIdEnv [ (l, Var e) | (l,e) <- blast_alist ]
blast_all_exps = map snd blast_alist
---------
- find_cand blast_list (CoRec _) = blast_list -- recursively paranoid, as usual
+ find_cand blast_list (Rec _) = blast_list -- recursively paranoid, as usual
- find_cand blast_list (CoNonRec binder rhs)
+ find_cand blast_list (NonRec binder rhs)
= if not (isExported binder) then
blast_list
else
undup blast_list
= -- pprTrace "undup input length:" (ppInt (length blast_list)) (
let
- (singles, dups) = removeDups cmp blast_list
+ (singles, dups) = removeDups compare blast_list
list_of_dups = concat dups
in
[ s | s <- singles, s `not_elem` list_of_dups ]
-- )
where
- cmp (x,_) (y,_) = x `cmpId` y
+ compare (x,_) (y,_) = x `cmp` y
------------------------------------------
- rhs_equiv_to_local_var (CoVar x)
+ rhs_equiv_to_local_var (Var x)
= if externallyVisibleId x then Nothing else Just x
rhs_equiv_to_local_var expr = Nothing
-{- MAYBE NOT:
- = case (digForLambdas expr) of { (tyvars, binders, body) ->
- case (collectArgs body) of { (fun, args) ->
- case fun of
- CoVar x -> if null binders
- && not (isExported x)
- && tylams_match_tyargs tyvars args then
- -- may need to chk for "tyvars" occurring in "x"'s type
- Just x
- else
- Nothing
- _ -> Nothing
- }}
- where
- -- looking for a very restricted special case:
- -- /\ tv1 tv2 ... -> var tv1 tv2 ...
-
- tylams_match_tyargs [] [] = True
- tylams_match_tyargs (tv:tvs) (TypeArg ty : args)
- = ASSERT(not (isPrimType ty))
- case (getTyVarMaybe ty) of
- Nothing -> False
- Just tyvar -> tv == tyvar
- tylams_match_tyargs _ _ = False
--}
------------------------------------------
-- "blast" does the substitution:
-- returns Nothing if a binding goes away
-- returns "Just b" to give back a fixed-up binding
- blast :: PlainCoreBinding -> SUniqSM (Maybe PlainCoreBinding)
+ blast :: CoreBinding -> UniqSM (Maybe CoreBinding)
- blast (CoRec pairs)
- = mapSUs blast_pr pairs `thenSUs` \ blasted_pairs ->
- returnSUs (Just (CoRec blasted_pairs))
+ blast (Rec pairs)
+ = mapUs blast_pr pairs `thenUs` \ blasted_pairs ->
+ returnUs (Just (Rec blasted_pairs))
where
blast_pr (binder, rhs)
- = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs ->
- returnSUs (
+ = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs ->
+ returnUs (
case lookupIdEnv blast_id_env binder of
Just exportee -> (exportee, blasted_rhs)
Nothing -> (binder, blasted_rhs)
)
- blast (CoNonRec binder rhs)
+ blast (NonRec binder rhs)
= if binder `is_elem` blast_all_exps then
- returnSUs Nothing -- this binding dies!
+ returnUs Nothing -- this binding dies!
else
- subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs ->
- returnSUs (Just (
+ subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs ->
+ returnUs (Just (
case lookupIdEnv blast_id_env binder of
- Just exportee -> CoNonRec exportee blasted_rhs
- Nothing -> CoNonRec binder blasted_rhs
+ Just exportee -> NonRec exportee blasted_rhs
+ Nothing -> NonRec binder blasted_rhs
))
where
is_elem = isIn "blast"
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplUtils where
-import BinderInfo(BinderInfo)
-import CoreSyn(CoreCaseAlternatives, CoreExpr)
-import Id(Id)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-etaExpandCount :: CoreExpr a Id -> Int
-floatExposesHNF :: Bool -> Bool -> Bool -> CoreExpr a Id -> Bool
-mkCoLamTryingEta :: [Id] -> CoreExpr Id Id -> CoreExpr Id Id
-mkCoTyLamTryingEta :: [TyVar] -> CoreExpr Id Id -> CoreExpr Id Id
-mkIdentityAlts :: UniType -> SplitUniqSupply -> SimplCount -> (CoreCaseAlternatives (Id, BinderInfo) Id, SimplCount)
-simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
-type_ok_for_let_to_case :: UniType -> Bool
-
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[SimplUtils]{The simplifier utilities}
module SimplUtils (
floatExposesHNF,
-
+
mkCoTyLamTryingEta, mkCoLamTryingEta,
etaExpandCount,
-
+
mkIdentityAlts,
simplIdWantsToBeINLINEd,
IMPORT_Trace -- ToDo: rm (debugging)
import Pretty
-import TaggedCore
-import PlainCore
import SimplEnv
import SimplMonad
import BinderInfo
-import AbsPrel ( primOpIsCheap, realWorldStateTy,
+import PrelInfo ( primOpIsCheap, realWorldStateTy,
buildId, augmentId
IF_ATTACK_PRAGMAS(COMMA realWorldTy)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( extractTyVarsFromTy, getTyVarMaybe, isPrimType,
- splitTypeWithDictsAsArgs, getUniDataTyCon_maybe,
+import Type ( extractTyVarsFromTy, getTyVarMaybe, isPrimType,
+ splitTypeWithDictsAsArgs, maybeDataTyCon,
applyTy, isFunType, TyVar, TyVarTemplate
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar COMMA cmpClass)
)
-import Id ( getInstantiatedDataConSig, isDataCon, getIdUniType,
+import Id ( getInstantiatedDataConSig, isDataCon, idType,
getIdArity, isBottomingId, idWantsToBeINLINEd,
DataCon(..), Id
)
:: Bool -- Float let(rec)s out of rhs
-> Bool -- Float cheap primops out of rhs
-> Bool -- OK to duplicate code
- -> CoreExpr bdr Id
+ -> GenCoreExpr bdr Id
-> Bool
floatExposesHNF float_lets float_primops ok_to_dup rhs
= try rhs
where
- try (CoCase (CoPrim _ _ _) (CoPrimAlts alts deflt) )
+ try (Case (Prim _ _ _) (PrimAlts alts deflt) )
| float_primops && (null alts || ok_to_dup)
= or (try_deflt deflt : map try_alt alts)
- try (CoLet bind body) | float_lets = try body
+ try (Let bind body) | float_lets = try body
-- `build g'
-- is like a HNF,
-- because it *will* become one.
-- likewise for `augment g h'
--
- try (CoApp (CoTyApp (CoVar bld) _) _) | bld == buildId = True
- try (CoApp (CoApp (CoTyApp (CoVar bld) _) _) _) | bld == augmentId = True
+ try (App (CoTyApp (Var bld) _) _) | bld == buildId = True
+ try (App (App (CoTyApp (Var bld) _) _) _) | bld == augmentId = True
try other = manifestlyWHNF other
{- but *not* necessarily "manifestlyBottom other"...
try_alt (lit,rhs) = try rhs
- try_deflt CoNoDefault = False
- try_deflt (CoBindDefault _ rhs) = try rhs
+ try_deflt NoDefault = False
+ try_deflt (BindDefault _ rhs) = try rhs
\end{code}
\ x y -> f x y ===> f
But we only do this if it gets rid of a whole lambda, not part.
-The idea is that lambdas are often quite helpful: they indicate
+The idea is that lambdas are often quite helpful: they indicate
head normal forms, so we don't want to chuck them away lightly.
But if they expose a simple variable then we definitely win. Even
if they expose a type application we win. So we check for this special
\begin{code}
mkCoLamTryingEta :: [Id] -- Args to the lambda
- -> PlainCoreExpr -- Lambda body
- -> PlainCoreExpr
+ -> CoreExpr -- Lambda body
+ -> CoreExpr
mkCoLamTryingEta [] body = body
mkCoLamTryingEta orig_ids body
= reduce_it (reverse orig_ids) body
where
- bale_out = mkCoLam orig_ids body
+ bale_out = mkValLam orig_ids body
reduce_it [] residual
| residual_ok residual = residual
| otherwise = bale_out
- reduce_it (id:ids) (CoApp fun (CoVarAtom arg))
+ reduce_it (id:ids) (App fun (VarArg arg))
| id == arg
- && getIdUniType id /= realWorldStateTy
- -- *never* eta-reduce away a PrimIO state token! (WDP 94/11)
+ && idType id /= realWorldStateTy
+ -- *never* eta-reduce away a PrimIO state token! (WDP 94/11)
= reduce_it ids fun
reduce_it ids other = bale_out
is_elem = isIn "mkCoLamTryingEta"
-----------
- residual_ok :: PlainCoreExpr -> Bool -- Checks for type application
- -- and function not one of the
+ residual_ok :: CoreExpr -> Bool -- Checks for type application
+ -- and function not one of the
-- bound vars
residual_ok (CoTyApp fun ty) = residual_ok fun
- residual_ok (CoVar v) = not (v `is_elem` orig_ids) -- Fun mustn't be one of
+ residual_ok (Var v) = not (v `is_elem` orig_ids) -- Fun mustn't be one of
-- the bound ids
residual_ok other = False
\end{code}
to represent "infinity", which is a bit of a hack.
\begin{code}
-etaExpandCount :: CoreExpr bdr Id
+etaExpandCount :: GenCoreExpr bdr Id
-> Int -- Number of extra args you can safely abstract
-etaExpandCount (CoLam ids body)
- = length ids + etaExpandCount body
+etaExpandCount (Lam _ body)
+ = 1 + etaExpandCount body
-etaExpandCount (CoLet bind body)
- | all manifestlyCheap (rhssOfBind bind)
+etaExpandCount (Let bind body)
+ | all manifestlyCheap (rhssOfBind bind)
= etaExpandCount body
-
-etaExpandCount (CoCase scrut alts)
- | manifestlyCheap scrut
+
+etaExpandCount (Case scrut alts)
+ | manifestlyCheap scrut
= minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
-etaExpandCount (CoApp fun _) = case etaExpandCount fun of
+etaExpandCount (App fun _) = case etaExpandCount fun of
0 -> 0
n -> n-1 -- Knock off one
etaExpandCount fun@(CoTyApp _ _) = eta_fun fun
-etaExpandCount fun@(CoVar _) = eta_fun fun
+etaExpandCount fun@(Var _) = eta_fun fun
etaExpandCount other = 0 -- Give up
- -- CoLit, CoCon, CoPrim,
+ -- Lit, Con, Prim,
-- CoTyLam,
- -- CoScc (pessimistic; ToDo),
- -- CoLet with non-whnf rhs(s),
- -- CoCase with non-whnf scrutinee
+ -- Scc (pessimistic; ToDo),
+ -- Let with non-whnf rhs(s),
+ -- Case with non-whnf scrutinee
-eta_fun :: CoreExpr bdr Id -- The function
+eta_fun :: GenCoreExpr bdr Id -- The function
-> Int -- How many args it can safely be applied to
eta_fun (CoTyApp fun ty) = eta_fun fun
-eta_fun expr@(CoVar v)
+eta_fun expr@(Var v)
| isBottomingId v -- Bottoming ids have "infinite arity"
= 10000 -- Blargh. Infinite enough!
-eta_fun expr@(CoVar v)
+eta_fun expr@(Var v)
| maybeToBool arity_maybe -- We know the arity
= arity
where
to bring a couple of lambdas together. The main examples of things
which aren't WHNF but are ``cheap'' are:
- * case e of
+ * case e of
pi -> ei
where e, and all the ei are cheap; and
where op is a cheap primitive operator
\begin{code}
-manifestlyCheap :: CoreExpr bndr Id -> Bool
+manifestlyCheap :: GenCoreExpr bndr Id -> Bool
-manifestlyCheap (CoVar _) = True
-manifestlyCheap (CoLit _) = True
-manifestlyCheap (CoCon _ _ _) = True
-manifestlyCheap (CoLam _ _) = True
+manifestlyCheap (Var _) = True
+manifestlyCheap (Lit _) = True
+manifestlyCheap (Con _ _ _) = True
+manifestlyCheap (Lam _ _) = True
manifestlyCheap (CoTyLam _ e) = manifestlyCheap e
-manifestlyCheap (CoSCC _ e) = manifestlyCheap e
+manifestlyCheap (SCC _ e) = manifestlyCheap e
-manifestlyCheap (CoPrim op _ _) = primOpIsCheap op
+manifestlyCheap (Prim op _ _) = primOpIsCheap op
-manifestlyCheap (CoLet bind body)
+manifestlyCheap (Let bind body)
= manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
-manifestlyCheap (CoCase scrut alts)
+manifestlyCheap (Case scrut alts)
= manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
manifestlyCheap other_expr -- look for manifest partial application
= case (collectArgs other_expr) of { (fun, args) ->
case fun of
- CoVar f | isBottomingId f -> True -- Application of a function which
+ Var f | isBottomingId f -> True -- Application of a function which
-- always gives bottom; we treat this as
-- a WHNF, because it certainly doesn't
-- need to be shared!
- CoVar f -> let
+ Var f -> let
num_val_args = length [ a | (ValArg a) <- args ]
- in
+ in
num_val_args == 0 || -- Just a type application of
-- a variable (f t1 t2 t3)
-- counts as WHNF
_ -> False
}
-
-
--- ToDo: Move to CoreFuns
-
-rhssOfBind :: CoreBinding bndr bdee -> [CoreExpr bndr bdee]
-
-rhssOfBind (CoNonRec _ rhs) = [rhs]
-rhssOfBind (CoRec pairs) = [rhs | (_,rhs) <- pairs]
-
-rhssOfAlts :: CoreCaseAlternatives bndr bdee -> [CoreExpr bndr bdee]
-
-rhssOfAlts (CoAlgAlts alts deflt) = rhssOfDeflt deflt ++
- [rhs | (_,_,rhs) <- alts]
-rhssOfAlts (CoPrimAlts alts deflt) = rhssOfDeflt deflt ++
- [rhs | (_,rhs) <- alts]
-rhssOfDeflt CoNoDefault = []
-rhssOfDeflt (CoBindDefault _ rhs) = [rhs]
\end{code}
Eta reduction on type lambdas
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have a go at doing
+We have a go at doing
/\a -> <expr> a ===> <expr>
f ab d = let d1 = ...d... in
letrec f' b x = ...d...(f' b)... in
f' b
-specialise ==>
+specialise ==>
f.Int b = letrec f' b x = ...dInt...(f' b)... in
f' b
-float ==>
+float ==>
f' b x = ...dInt...(f' b)...
f.Int b = f' b
-Now we really want to simplify to
+Now we really want to simplify to
f.Int = f'
/\ a -> f Char# a =NO=> f Char#
\begin{code}
-mkCoTyLamTryingEta :: [TyVar] -> PlainCoreExpr -> PlainCoreExpr
+mkCoTyLamTryingEta :: [TyVar] -> CoreExpr -> CoreExpr
mkCoTyLamTryingEta tyvars tylam_body
= if
strip_tyvar_args args_so_far fun
= (args_so_far, fun)
- check_fun (CoVar f) = True -- Claim: tyvars not mentioned by type of f
+ check_fun (Var f) = True -- Claim: tyvars not mentioned by type of f
check_fun other = False
-
-{- OLD:
-mkCoTyLamTryingEta :: TyVar -> PlainCoreExpr -> PlainCoreExpr
-
-mkCoTyLamTryingEta tyvar body
- = case body of
- CoTyApp fun ty ->
- case getTyVarMaybe ty of
- Just tyvar' | tyvar == tyvar' &&
- ok fun -> fun
- -- Ha! So it's /\ a -> fun a, and fun is "ok"
-
- other -> CoTyLam tyvar body
- other -> CoTyLam tyvar body
- where
- is_elem = isIn "mkCoTyLamTryingEta"
-
- ok :: PlainCoreExpr -> Bool -- Returns True iff the expression doesn't
- -- mention tyvar
-
- ok (CoVar v) = True -- Claim: tyvar not mentioned by type of v
- ok (CoApp fun arg) = ok fun -- Claim: tyvar not mentioned by type of arg
- ok (CoTyApp fun ty) = not (tyvar `is_elem` extractTyVarsFromTy ty) &&
- ok fun
- ok other = False
--}
\end{code}
Let to case
\begin{code}
mkIdentityAlts
- :: UniType -- type of RHS
+ :: Type -- type of RHS
-> SmplM InAlts -- result
mkIdentityAlts rhs_ty
| isPrimType rhs_ty
= newId rhs_ty `thenSmpl` \ binder ->
- returnSmpl (CoPrimAlts [] (CoBindDefault (binder, bad_occ_info) (CoVar binder)))
+ returnSmpl (PrimAlts [] (BindDefault (binder, bad_occ_info) (Var binder)))
| otherwise
- = case getUniDataTyCon_maybe rhs_ty of
+ = case maybeDataTyCon rhs_ty of
Just (tycon, ty_args, [data_con]) -> -- algebraic type suitable for unpacking
let
(_,inst_con_arg_tys,_) = getInstantiatedDataConSig data_con ty_args
in
newIds inst_con_arg_tys `thenSmpl` \ new_bindees ->
let
- new_binders = [ (b, bad_occ_info) | b <- new_bindees ]
+ new_binders = [ (b, bad_occ_info) | b <- new_bindees ]
in
returnSmpl (
- CoAlgAlts
- [(data_con, new_binders, CoCon data_con ty_args (map CoVarAtom new_bindees))]
- CoNoDefault
+ AlgAlts
+ [(data_con, new_binders, Con data_con ty_args (map VarArg new_bindees))]
+ NoDefault
)
- _ -> -- Multi-constructor or abstract algebraic type
+ _ -> -- Multi-constructor or abstract algebraic type
newId rhs_ty `thenSmpl` \ binder ->
- returnSmpl (CoAlgAlts [] (CoBindDefault (binder,bad_occ_info) (CoVar binder)))
+ returnSmpl (AlgAlts [] (BindDefault (binder,bad_occ_info) (Var binder)))
where
bad_occ_info = ManyOcc 0 -- Non-committal!
\end{code}
\begin{code}
simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
-simplIdWantsToBeINLINEd id env
- = if switchIsSet env IgnoreINLINEPragma
+simplIdWantsToBeINLINEd id env
+ = if switchIsSet env IgnoreINLINEPragma
then False
else idWantsToBeINLINEd id
-type_ok_for_let_to_case :: UniType -> Bool
+type_ok_for_let_to_case :: Type -> Bool
-type_ok_for_let_to_case ty
- = case getUniDataTyCon_maybe ty of
+type_ok_for_let_to_case ty
+ = case maybeDataTyCon ty of
Nothing -> False
Just (tycon, ty_args, []) -> False
Just (tycon, ty_args, non_null_data_cons) -> True
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplVar where
-import CoreSyn(CoreArg, CoreExpr)
-import Id(Id)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-completeVar :: SimplEnv -> Id -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-leastItCouldCost :: Int -> Int -> Int -> [Bool] -> [UniType] -> Int
-
leastItCouldCost
) where
-IMPORT_Trace
-
import SimplMonad
import SimplEnv
-import PlainCore
-import TaggedCore
-import BasicLit ( isNoRepLit )
+import Literal ( isNoRepLit )
-import AbsUniType ( getUniDataTyCon, getUniDataTyCon_maybe,
+import Type ( getAppDataTyCon, maybeAppDataTyCon,
getTyConFamilySize, isPrimType
)
import BinderInfo ( oneTextualOcc, oneSafeOcc )
uNFOLDING_CON_DISCOUNT_WEIGHT
)
import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) )
-import Id ( getIdUniType, getIdInfo )
+import Id ( idType, getIdInfo )
import IdInfo
import Maybes ( maybeToBool, Maybe(..) )
import Simplify ( simplExpr )
completeVar env var args
= let
- boring_result = applyToArgs (CoVar var) args
+ boring_result = mkGenApp (Var var) args
in
case (lookupUnfolding env var) of
-
- LiteralForm lit
- | not (isNoRepLit lit)
+
+ LitForm lit
+ | not (isNoRepLit lit)
-- Inline literals, if they aren't no-repish things
-> ASSERT( null args )
- returnSmpl (CoLit lit)
+ returnSmpl (Lit lit)
- ConstructorForm con ty_args val_args
+ ConForm con ty_args val_args
-- Always inline constructors.
-- See comments before completeLetBinding
-> ASSERT( null args )
- returnSmpl (CoCon con ty_args val_args)
+ returnSmpl (Con con ty_args val_args)
- GeneralForm txt_occ form_summary template guidance
+ GenForm txt_occ form_summary template guidance
-> considerUnfolding env var args
txt_occ form_summary template guidance
-> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
case result of
Nothing -> returnSmpl boring_result
- Just magic_result ->
+ Just magic_result ->
{- pprTrace "MagicForm:- " (ppAbove
(ppBesides [
ppr PprDebug var,
-> FormSummary
-> InExpr -- Template for unfolding;
-> UnfoldingGuidance -- To help us decide...
- -> SmplM PlainCoreExpr -- Result!
+ -> SmplM CoreExpr -- Result!
considerUnfolding env var args txt_occ form_summary template guidance
| switchIsOn sw_chkr EssentialUnfoldingsOnly
dont_go_for_it
else if n_vals_wanted == 0
- && rhs_looks_like_a_CoCon then
+ && rhs_looks_like_a_Con then
-- we are very keen on inlining data values
-- (see comments elsewhere); we ignore any size issues!
go_for_it
no_tyargs = length tyargs
no_valargs = length valargs
- rhs_looks_like_a_CoCon
+ rhs_looks_like_a_Con
= let
- (_,val_binders,body) = digForLambdas template
+ (_,_,val_binders,body) = digForLambdas template
in
case (val_binders, body) of
- ([], CoCon _ _ _) -> True
+ ([], Con _ _ _) -> True
other -> False
- dont_go_for_it = returnSmpl (applyToArgs (CoVar var) args)
+ dont_go_for_it = returnSmpl (mkGenApp (Var var) args)
go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
tick UnfoldingDone `thenSmpl_`
-> Int -- the number of val args (== length args)
-> ArgInfoVector -- what we know about the *use* of the arguments
-> [OutAtom] -- *an actual set of value arguments*!
- -> Int
+ -> Int
-- If we apply an expression (usually a function) of given "costs"
-- to a particular set of arguments (possibly none), what will
= let
full_price = disc size
take_something_off v = let
- (tycon, _, _) = getUniDataTyCon (getIdUniType v)
+ (tycon, _, _) = getAppDataTyCon (idType v)
no_cons = case (getTyConFamilySize tycon) of
Just n -> n
reduced_size
full_price
else
case arg of
- CoLitAtom _ -> full_price
- CoVarAtom v -> case lookupUnfolding env v of
- ConstructorForm _ _ _ -> take_something_off v
+ LitArg _ -> full_price
+ VarArg v -> case lookupUnfolding env v of
+ ConForm _ _ _ -> take_something_off v
other_form -> full_price
) want_cons rest_args
-> Int -- the size/cost of the expr
-> Int -- number of value args
-> ArgInfoVector -- what we know about the *use* of the arguments
- -> [UniType] -- NB: actual arguments *not* looked at;
+ -> [Type] -- NB: actual arguments *not* looked at;
-- but we know their types
-> Int
if not want_con_here then
disc size want_cons rest_arg_tys
else
- case (getUniDataTyCon_maybe arg_ty, isPrimType arg_ty) of
+ case (maybeAppDataTyCon arg_ty, isPrimType arg_ty) of
(Just (tycon, _, _), False) ->
- disc (take_something_off tycon) want_cons rest_arg_tys
+ disc (take_something_off tycon) want_cons rest_arg_tys
other -> disc size want_cons rest_arg_tys
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Simplify where
-import BinderInfo(BinderInfo)
-import CoreSyn(CoreArg, CoreBinding, CoreExpr)
-import Id(Id)
-import SimplEnv(SimplEnv)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import UniType(UniType)
-simplBind :: SimplEnv -> CoreBinding (Id, BinderInfo) Id -> (SimplEnv -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> UniType -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-simplExpr :: SimplEnv -> CoreExpr (Id, BinderInfo) Id -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
-simplTopBinds :: SimplEnv -> [CoreBinding (Id, BinderInfo) Id] -> SplitUniqSupply -> SimplCount -> ([CoreBinding Id Id], SimplCount)
-
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[Simplify]{The main module of the simplifier}
import SimplMonad
import SimplEnv
-import TaggedCore
-import PlainCore
-import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..),
- primOpOkForSpeculation, PrimOp(..), PrimKind,
+import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..),
+ primOpOkForSpeculation, PrimOp(..), PrimRep,
realWorldStateTy
IF_ATTACK_PRAGMAS(COMMA realWorldTy)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( getUniDataTyCon_maybe, mkTyVarTy, applyTy,
+import Type ( maybeDataTyCon, mkTyVarTy, applyTy,
splitTyArgs, splitTypeWithDictsAsArgs,
maybeUnpackFunTy, isPrimType
)
-import BasicLit ( isNoRepLit, BasicLit(..) )
+import Literal ( isNoRepLit, Literal(..) )
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
-fsimplify = run the simplifier
-ffloat-inwards = runs the float lets inwards pass
-ffloat = runs the full laziness pass
- (ToDo: rename to -ffull-laziness)
+ (ToDo: rename to -ffull-laziness)
-fupdate-analysis = runs update analyser
-fstrictness = runs strictness analyser
-fsaturate-apps = saturates applications (eta expansion)
options:
-------
-ffloat-past-lambda = OK to do full laziness.
- (ToDo: remove, as the full laziness pass is
- useless without this flag, therefore
- it is unnecessary. Just -ffull-laziness
- should be kept.)
+ (ToDo: remove, as the full laziness pass is
+ useless without this flag, therefore
+ it is unnecessary. Just -ffull-laziness
+ should be kept.)
-ffloat-lets-ok = OK to float lets out of lets if the enclosing
- let is strict or if the floating will expose
- a WHNF [simplifier].
+ let is strict or if the floating will expose
+ a WHNF [simplifier].
--ffloat-primops-ok = OK to float out of lets cases whose scrutinee
- is a primop that cannot fail [simplifier].
+-ffloat-primops-ok = OK to float out of lets cases whose scrutinee
+ is a primop that cannot fail [simplifier].
-fcode-duplication-ok = allows the previous option to work on cases with
- multiple branches [simplifier].
+ multiple branches [simplifier].
-flet-to-case = does let-to-case transformation [simplifier].
Head normal forms
~~~~~~~~~~~~~~~~~
We *never* put a non-HNF unfolding in the UnfoldEnv except in the
-INLINE-pragma case.
+INLINE-pragma case.
At one time I thought it would be OK to put non-HNF unfoldings in for
variables which occur only once [if they got inlined at that
@
Now, it seems that @x@ appears only once, but even so it is NOT safe to put @x@
in the UnfoldEnv, because @f@ will be inlined, and will duplicate the references to
-@x@.
+@x@.
Becuase of this, the "unconditional-inline" mechanism above is the only way
in which non-HNFs can get inlined.
things in the UnfoldEnv with UnfoldAlways flags, which originated in
other INLINE pragmas.)
-So, we clean out the UnfoldEnv of all GeneralForm inlinings before
+So, we clean out the UnfoldEnv of all GenForm inlinings before
going into such an RHS.
What about imports? They don't really matter much because we only
-- Dead code is now discarded by the occurrence analyser,
-simplTopBinds env (CoNonRec binder@(in_id, occ_info) rhs : binds)
+simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)
| inlineUnconditionally ok_to_dup_code occ_info
= --pprTrace "simplTopBinds (inline):" (ppr PprDebug in_id) (
let
where
ok_to_dup_code = switchIsSet env SimplOkToDupCode
-simplTopBinds env (CoNonRec binder@(in_id,occ_info) rhs : binds)
+simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
= -- No cloning necessary at top level
-- Process the binding
simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
let
new_env = case rhs' of
- CoVar var -> extendIdEnvWithAtom env binder (CoVarAtom var)
- CoLit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (CoLitAtom lit)
- other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
+ Var var -> extendIdEnvWithAtom env binder (VarArg var)
+ Lit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (LitArg lit)
+ other -> extendUnfoldEnvGivenRhs env binder in_id rhs'
in
--pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug rhs']) (
simplTopBinds new_env binds `thenSmpl` \ binds' ->
-- Glue together and return ...
- -- We leave it to susequent occurrence analysis to throw away
+ -- We leave it to susequent occurrence analysis to throw away
-- an unused atom binding. This localises the decision about
-- discarding top-level bindings.
- returnSmpl (CoNonRec in_id rhs' : binds')
+ returnSmpl (NonRec in_id rhs' : binds')
--)
-simplTopBinds env (CoRec pairs : binds)
+simplTopBinds env (Rec pairs : binds)
= simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) ->
--pprTrace "simplTopBinds (rec):" (ppCat [ppr PprDebug bind']) (
%* *
%************************************************************************
-
-\begin{code}
+
+\begin{code}
simplExpr :: SimplEnv
-> InExpr -> [OutArg]
- -> SmplM OutExpr
+ -> SmplM OutExpr
\end{code}
The expression returned has the same meaning as the input expression
do the more sophisticated stuff.
\begin{code}
-simplExpr env (CoVar v) args
+simplExpr env (Var v) args
= --pprTrace "simplExpr:Var:" (ppr PprDebug v) (
case lookupId env v of
Nothing -> let
Just info ->
case info of
- ItsAnAtom (CoLitAtom lit) -- A boring old literal
+ ItsAnAtom (LitArg lit) -- A boring old literal
-- Paranoia check for args empty
-> case args of
- [] -> returnSmpl (CoLit lit)
+ [] -> returnSmpl (Lit lit)
other -> panic "simplExpr:coVar"
- ItsAnAtom (CoVarAtom var) -- More interesting! An id!
+ ItsAnAtom (VarArg var) -- More interesting! An id!
-- No need to substitute the type env here,
-- because we already have!
- -> completeVar env var args
-
+ -> completeVar env var args
+
InlineIt id_env ty_env in_expr -- A macro-expansion
-> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
--)
~~~~~~~~~
\begin{code}
-simplExpr env (CoLit l) [] = returnSmpl (CoLit l)
-simplExpr env (CoLit l) _ = panic "simplExpr:CoLit with argument"
+simplExpr env (Lit l) [] = returnSmpl (Lit l)
+simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument"
\end{code}
-Primitive applications are simple.
+Primitive applications are simple.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-NB: CoPrim expects an empty argument list! (Because it should be
+NB: Prim expects an empty argument list! (Because it should be
saturated and not higher-order. ADR)
-\begin{code}
-simplExpr env (CoPrim op tys prim_args) args
+\begin{code}
+simplExpr env (Prim op tys prim_args) args
= ASSERT (null args)
let
tys' = [simplTy env ty | ty <- tys]
where
-- PrimOps just need any types in them renamed.
- simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
+ simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
= let
arg_tys' = map (simplTy env) arg_tys
result_ty' = simplTy env result_ty
simpl_op other_op = other_op
\end{code}
-Constructor applications
-~~~~~~~~~~~~~~~~~~~~~~~~
+Constructor applications
+~~~~~~~~~~~~~~~~~~~~~~~~
Nothing to try here. We only reuse constructors when they appear as the
rhs of a let binding (see completeLetBinding).
\begin{code}
-simplExpr env (CoCon con tys con_args) args
+simplExpr env (Con con tys con_args) args
= ASSERT( null args )
- returnSmpl (CoCon con tys' con_args')
+ returnSmpl (Con con tys' con_args')
where
con_args' = [simplAtom env con_arg | con_arg <- con_args]
tys' = [simplTy env ty | ty <- tys]
\end{code}
-Applications are easy too:
-~~~~~~~~~~~~~~~~~~~~~~~~~~
+Applications are easy too:
+~~~~~~~~~~~~~~~~~~~~~~~~~~
Just stuff 'em in the arg stack
-\begin{code}
-simplExpr env (CoApp fun arg) args
+\begin{code}
+simplExpr env (App fun arg) args
= simplExpr env fun (ValArg (simplAtom env arg) : args)
simplExpr env (CoTyApp fun ty) args
be eta-reduced. This requires us to collect up all tyvar parameters so
we can pass them all to @mkCoTyLamTryingEta@.
-\begin{code}
+\begin{code}
simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
= -- ASSERT(not (isPrimType ty))
let
simplExpr new_env body args
simplExpr env tylam@(CoTyLam tyvar body) []
- = do_tylambdas env [] tylam
+ = do_tylambdas env [] tylam
where
do_tylambdas env tyvars' (CoTyLam tyvar body)
= -- Clone the type variable
)
simplExpr env (CoTyLam tyvar body) (ValArg _ : _)
- = panic "simplExpr:CoTyLam ValArg"
+ = panic "simplExpr:CoTyLam ValArg"
\end{code}
~~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env (CoLam binders body) args
+simplExpr env (Lam binder body) args
| null leftover_binders
= -- The lambda is saturated (or over-saturated)
tick BetaReduction `thenSmpl_`
else returnSmpl (panic "BetaReduction")
) `thenSmpl_`
- simplLam env_for_too_few_args leftover_binders body
+ simplLam env_for_too_few_args leftover_binders body
0 {- Guaranteed applied to at least 0 args! -}
where
- (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binders args
+ (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args [binder] args
env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs
-- (\ x y z -> e) p q r
-- ==> e[p/x, q/y, r/z]
--
- zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
+ zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)
| ((id, occ_info), arg) <- binder_args_pairs ]
collect_val_args :: [InBinder] -- Binders
-> ([(InBinder,OutAtom)], -- Binder,arg pairs
[InBinder], -- Leftover binders
[OutArg]) -- Leftover args
-
+
-- collect_val_args strips off the leading ValArgs from
-- the current arg list, returning them along with the
-- depleted list
(rest_pairs, leftover_binders, leftover_args) = collect_val_args binders args
collect_val_args (binder:binders) (other_val_arg : args) = panic "collect_val_args"
- -- TypeArg should never meet a CoLam
+ -- TypeArg should never meet a Lam
\end{code}
-Let expressions
+Let expressions
~~~~~~~~~~~~~~~
-\begin{code}
-simplExpr env (CoLet bind body) args
+\begin{code}
+simplExpr env (Let bind body) args
| not (switchIsSet env SimplNoLetFromApp) -- The common case
- = simplBind env bind (\env -> simplExpr env body args)
+ = simplBind env bind (\env -> simplExpr env body args)
(computeResultType env body args)
| otherwise -- No float from application
- = simplBind env bind (\env -> simplExpr env body [])
+ = simplBind env bind (\env -> simplExpr env body [])
(computeResultType env body []) `thenSmpl` \ let_expr' ->
- returnSmpl (applyToArgs let_expr' args)
+ returnSmpl (mkGenApp let_expr' args)
\end{code}
-Case expressions
+Case expressions
~~~~~~~~~~~~~~~~
\begin{code}
-simplExpr env expr@(CoCase scrut alts) args
+simplExpr env expr@(Case scrut alts) args
= simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
(computeResultType env expr args)
\end{code}
-Set-cost-centre
+Set-cost-centre
~~~~~~~~~~~~~~~
A special case we do:
interfaces change less (arities).
\begin{code}
-simplExpr env (CoSCC cc (CoLam binders body)) args
- = simplExpr env (CoLam binders (CoSCC cc body)) args
+simplExpr env (SCC cc (Lam binder body)) args
+ = simplExpr env (Lam binder (SCC cc body)) args
-simplExpr env (CoSCC cc (CoTyLam tyvar body)) args
- = simplExpr env (CoTyLam tyvar (CoSCC cc body)) args
+simplExpr env (SCC cc (CoTyLam tyvar body)) args
+ = simplExpr env (CoTyLam tyvar (SCC cc body)) args
\end{code}
Some other slightly turgid SCC tidying-up cases:
\begin{code}
-simplExpr env (CoSCC cc1 expr@(CoSCC _ _)) args
+simplExpr env (SCC cc1 expr@(SCC _ _)) args
= simplExpr env expr args
- -- the outer _scc_ serves no purpose
+ -- the outer _scc_ serves no purpose
-simplExpr env (CoSCC cc expr) args
+simplExpr env (SCC cc expr) args
| squashableDictishCcExpr cc expr
= simplExpr env expr args
-- the DICT-ish CC is no longer serving any purpose
ToDo: check with Patrick that this is ok.
\begin{code}
-simplExpr env (CoSCC cost_centre body) args
+simplExpr env (SCC cost_centre body) args
= let
new_env = setEnclosingCC env (EnclosingCC cost_centre)
in
simplExpr new_env body args `thenSmpl` \ body' ->
- returnSmpl (CoSCC cost_centre body')
+ returnSmpl (SCC cost_centre body')
\end{code}
%************************************************************************
This is a Very Good Thing!
\begin{code}
-simplRhsExpr
+simplRhsExpr
:: SimplEnv
-> InBinder
-> InExpr
- -> SmplM OutExpr
+ -> SmplM OutExpr
-simplRhsExpr env binder@(id,occ_info) rhs
+simplRhsExpr env binder@(id,occ_info) rhs
| dont_eta_expand rhs
= simplExpr rhs_env rhs []
-- we might want a {-# INLINE UNSIMPLIFIED #-} option.
rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
| otherwise = env
-
- (tyvars, binders, body) = digForLambdas rhs
+
+ (uvars, tyvars, binders, body) = digForLambdas rhs
min_no_of_args | not (null binders) && -- It's not a thunk
switchIsSet env SimplDoArityExpand -- Arity expansion on
-- get eta-reduced back to y. Furthermore, if this was a top level defn,
-- and x was exported, then the defn won't be eliminated, so this
-- silly expand/reduce cycle will happen every time, which makes the
- -- simplifier loop!.
+ -- simplifier loop!.
-- The solution is to not even try eta expansion unless the rhs looks
- -- non-trivial.
- dont_eta_expand (CoLit _) = True
- dont_eta_expand (CoVar _) = True
+ -- non-trivial.
+ dont_eta_expand (Lit _) = True
+ dont_eta_expand (Var _) = True
dont_eta_expand (CoTyApp f _) = dont_eta_expand f
dont_eta_expand (CoTyLam _ b) = dont_eta_expand b
- dont_eta_expand (CoCon _ _ _) = True
+ dont_eta_expand (Con _ _ _) = True
dont_eta_expand _ = False
\end{code}
-
+
%************************************************************************
%* *
\subsection{Simplify a lambda abstraction}
returnSmpl (
(if switchIsSet new_env SimplDoEtaReduction
then mkCoLamTryingEta
- else mkCoLam) binders' body'
+ else mkValLam) binders' body'
)
| otherwise -- Eta expansion possible
new_env = extendIdEnvWithClones env binders binders'
in
newIds extra_binder_tys `thenSmpl` \ extra_binders' ->
- simplExpr new_env body (map (ValArg.CoVarAtom) extra_binders') `thenSmpl` \ body' ->
+ simplExpr new_env body (map (ValArg.VarArg) extra_binders') `thenSmpl` \ body' ->
returnSmpl (
(if switchIsSet new_env SimplDoEtaReduction
then mkCoLamTryingEta
- else mkCoLam) (binders' ++ extra_binders') body'
+ else mkValLam) (binders' ++ extra_binders') body'
)
where
- (potential_extra_binder_tys, res_ty)
- = splitTyArgs (simplTy env (typeOfCoreExpr (unTagBinders body)))
+ (potential_extra_binder_tys, res_ty)
+ = splitTyArgs (simplTy env (coreExprType (unTagBinders body)))
-- Note: it's possible that simplLam will be applied to something
-- with a forall type. Eg when being applied to the rhs of
-- let x = wurble
==>
let join_body x' = foldr c n x'
- in case y of
- p1 -> let x* = build e1
- in join_body x*
- p2 -> let x* = build e2
- in join_body x*
+ in case y of
+ p1 -> let x* = build e1
+ in join_body x*
+ p2 -> let x* = build e2
+ in join_body x*
note that join_body is a let-no-escape.
In this particular example join_body will later be inlined,
\begin{code}
-- Dead code is now discarded by the occurrence analyser,
-simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
+simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
| inlineUnconditionally ok_to_dup occ_info
= body_c (extendIdEnvWithInlining env env binder rhs)
-- If we do case-floating first we get this:
--
-- let k = \a* -> b
--- in case v of
+-- in case v of
-- p1-> let a*=e1 in k a
-- p2-> let a*=e2 in k a
--
-- The latter is clearly better. (Remember the reboxing let-decl
-- for a is likely to go away, because after all b is strict in a.)
- | will_be_demanded &&
+ | will_be_demanded &&
try_let_to_case &&
type_ok_for_let_to_case rhs_ty &&
not (manifestlyWHNF rhs)
-}
| (will_be_demanded && not no_float) ||
- always_float_let_from_let ||
+ always_float_let_from_let ||
floatExposesHNF float_lets float_primops ok_to_dup rhs
= try_float env rhs body_c
where
will_be_demanded = willBeDemanded (getIdDemandInfo id)
- rhs_ty = getIdUniType id
+ rhs_ty = idType id
float_lets = switchIsSet env SimplFloatLetsExposingWHNF
float_primops = switchIsSet env SimplOkToFloatPrimOps
completeLet env binder rhs rhs' body_c body_ty
---------------------------------------
- try_float env (CoLet bind rhs) body_c
+ try_float env (Let bind rhs) body_c
= tick LetFloatFromLet `thenSmpl_`
- simplBind env (fix_up_demandedness will_be_demanded bind)
+ simplBind env (fix_up_demandedness will_be_demanded bind)
(\env -> try_float env rhs body_c) body_ty
- try_float env (CoCase scrut alts) body_c
+ try_float env (Case scrut alts) body_c
| will_be_demanded || (float_primops && is_cheap_prim_app scrut)
= tick CaseFloatFromLet `thenSmpl_`
-- First, bind large let-body if necessary
if no_need_to_bind_large_body then
simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
- else
+ else
bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
let
body_c' = \env -> simplExpr env new_body []
in
- simplCase env scrut alts
+ simplCase env scrut alts
(\env rhs -> try_float env rhs body_c')
body_ty `thenSmpl` \ case_expr ->
- returnSmpl (CoLet extra_binding case_expr)
+ returnSmpl (Let extra_binding case_expr)
where
no_need_to_bind_large_body
= ok_to_dup || isSingleton (nonErrorRHSs alts)
try_float env other_rhs body_c = done_float env other_rhs body_c
\end{code}
-Letrec expressions
+Letrec expressions
~~~~~~~~~~~~~~~~~~
Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
letrec
f = ....g...
g = ....f...
- in
+ in
....f...
Here we would like the single call to g to be inlined.
/= a b = unpack tuple a, unpack tuple b, call f
in d.Eq
-here, by knowing about d.Eq in f's rhs, one could get rid of
+here, by knowing about d.Eq in f's rhs, one could get rid of
the case (and break out the recursion completely).
-[This occurred with more aggressive inlining threshold (4),
+[This occurred with more aggressive inlining threshold (4),
nofib/spectral/knights]
-How to do it?
+How to do it?
1: we simplify constructor rhss first.
2: we record the "known constructors" in the environment
3: we simplify the other rhss, with the knowledge about the constructors
\begin{code}
-simplBind env (CoRec pairs) body_c body_ty
+simplBind env (Rec pairs) body_c body_ty
= -- Do floating, if necessary
(if float_lets || always_float_let_from_let
- then
+ then
mapSmpl float pairs `thenSmpl` \ floated_pairs_s ->
returnSmpl (concat floated_pairs_s)
else
body_c new_env `thenSmpl` \ body' ->
- returnSmpl (CoLet binding body')
+ returnSmpl (Let binding body')
where
------------ Floating stuff -------------------
float_pair (binder, rhs)
| always_float_let_from_let ||
floatExposesHNF True False False rhs
- = (binder,rhs') : pairs'
+ = (binder,rhs') : pairs'
| otherwise
= [(binder,rhs)]
- where
+ where
(pairs', rhs') = do_float rhs
-- Float just pulls out any top-level let(rec) bindings
do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
- do_float (CoLet (CoRec pairs) body) = (float_pairs pairs ++ pairs', body')
- where
- (pairs', body') = do_float body
- do_float (CoLet (CoNonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
- where
- (pairs', body') = do_float body
+ do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
+ where
+ (pairs', body') = do_float body
+ do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
+ where
+ (pairs', body') = do_float body
do_float other = ([], other)
simplRecursiveGroup env triples
(early_triples, late_triples)
= partition is_early_triple ordinary_triples
- is_early_triple (_, (_, CoCon _ _ _)) = True
+ is_early_triple (_, (_, Con _ _ _)) = True
is_early_triple (i, _ ) = idWantsToBeINLINEd i
in
-- Process the early bindings first
-- Now further extend the environment to record our knowledge
-- about the form of the binders bound in the constructor bindings
let
- env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
- add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
+ env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
+ add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
in
-- Now process the non-constructor bindings
mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
-- Phew! We're done
let
- binding = CoRec (map snd early_triples' ++ map snd late_triples')
+ binding = Rec (map snd early_triples' ++ map snd late_triples')
in
returnSmpl (binding, env_w_early_info)
where
- do_one_binding env (id', (binder,rhs))
+ do_one_binding env (id', (binder,rhs))
= simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
returnSmpl (binder, (id', rhs'))
\end{code}
@completeLet@ looks at the simplified post-floating RHS of the
let-expression, and decides what to do. There's one interesting
aspect to this, namely constructor reuse. Consider
-@
+@
f = \x -> case x of
(y:ys) -> y:ys
[] -> ...
a.s3299 :: Int
_N_ {-# U(P) #-}
a.s3299 = I#! upk.s3297#
- } in
+ } in
case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
_LT -> I#! upk.s3298#
_EQ -> a.s3299
variable) when we find a let-expression:
@
let x = C a1 .. an
- in
- ... (let y = C a1 .. an in ...) ...
+ in
+ ... (let y = C a1 .. an in ...) ...
@
where it is always good to ditch the binding for y, and replace y by
x. That's just what completeLetBinding does.
body_c new_env
-- Maybe the rhs is an application of error, and sure to be demanded
- | will_be_demanded &&
+ | will_be_demanded &&
maybeToBool maybe_error_app
= tick CaseOfError `thenSmpl_`
returnSmpl retyped_error_app
new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs)
in
body_c new_env `thenSmpl` \ body' ->
- returnSmpl (CoLet (CoNonRec id' new_rhs) body')
+ returnSmpl (Let (NonRec id' new_rhs) body')
where
will_be_demanded = willBeDemanded (getIdDemandInfo id)
maybe_atomic_rhs
= case new_rhs of
- CoVar var -> Just (CoVarAtom var, AtomicRhs)
+ Var var -> Just (VarArg var, AtomicRhs)
- CoLit lit | not (isNoRepLit lit)
- -> Just (CoLitAtom lit, AtomicRhs)
+ Lit lit | not (isNoRepLit lit)
+ -> Just (LitArg lit, AtomicRhs)
- CoCon con tys con_args
- | try_to_reuse_constr
+ Con con tys con_args
+ | try_to_reuse_constr
-- Look out for
-- let v = C args
- -- in
+ -- in
--- ...(let w = C same-args in ...)...
-- Then use v instead of w. This may save
-- re-constructing an existing constructor.
-> case lookForConstructor env con tys con_args of
Nothing -> Nothing
- Just var -> Just (CoVarAtom var, ConReused)
+ Just var -> Just (VarArg var, ConReused)
other -> Nothing
\begin{code}
simplAtom :: SimplEnv -> InAtom -> OutAtom
-simplAtom env (CoLitAtom lit) = CoLitAtom lit
+simplAtom env (LitArg lit) = LitArg lit
-simplAtom env (CoVarAtom id)
+simplAtom env (VarArg id)
| isLocallyDefined id
= case lookupId env id of
Just (ItsAnAtom atom) -> atom
Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
- Nothing -> CoVarAtom id -- Must be an uncloned thing
+ Nothing -> VarArg id -- Must be an uncloned thing
| otherwise
= -- Not locally defined, so no change
- CoVarAtom id
+ VarArg id
\end{code}
\begin{code}
-- fix_up_demandedness switches off the willBeDemanded Info field
-- for bindings floated out of a non-demanded let
-fix_up_demandedness True {- Will be demanded -} bind
+fix_up_demandedness True {- Will be demanded -} bind
= bind -- Simple; no change to demand info needed
-fix_up_demandedness False {- May not be demanded -} (CoNonRec binder rhs)
- = CoNonRec (un_demandify binder) rhs
-fix_up_demandedness False {- May not be demanded -} (CoRec pairs)
- = CoRec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
+fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
+ = NonRec (un_demandify binder) rhs
+fix_up_demandedness False {- May not be demanded -} (Rec pairs)
+ = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
-is_cheap_prim_app (CoPrim op tys args) = primOpOkForSpeculation op
+is_cheap_prim_app (Prim op tys args) = primOpOkForSpeculation op
is_cheap_prim_app other = False
computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType
computeResultType env expr args
= do expr_ty' args
where
- expr_ty = typeOfCoreExpr (unTagBinders expr)
+ expr_ty = coreExprType (unTagBinders expr)
expr_ty' = simplTy env expr_ty
do ty [] = ty
--- /dev/null
+Breaks the loop between SimplEnv and MagicUFs, by telling SimplEnv all
+it needs to know about MagicUFs (not much).
+
+\begin{code}
+interface SmplLoop where
+
+import MagicUFs (MagicUnfoldingFun )
+
+data MagicUnfoldingFun
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface LambdaLift where
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgBinding)
-liftProgram :: SplitUniqSupply -> [StgBinding Id Id] -> [StgBinding Id Id]
-
import StgSyn
-import AbsUniType ( mkForallTy, splitForalls, glueTyArgs,
- UniType, RhoType(..), TauType(..)
+import Type ( mkForallTy, splitForalls, glueTyArgs,
+ Type, RhoType(..), TauType(..)
)
import Bag
-import Id ( mkSysLocal, getIdUniType, addIdArity, Id )
-import IdEnv
+import Id ( mkSysLocal, idType, addIdArity, Id )
import Maybes
-import SplitUniq
+import UniqSupply
import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
import UniqSet
import Util
* Non-recursive bindings whose RHS is a lambda abstractions are lifted,
provided all the occurrences of the bound variable is in a function
postition. In this example, f will be lifted:
-
- let
+
+ let
f = \x -> e
in
..(f a1)...(f a2)...
But in this case, f won't be lifted:
- let
+ let
f = \x -> e
in
..(g f)...(f a2)...
let
f = $f p q r
- in
+ in
..(g f)...($f p q r a2)..
so it might as well be the original lambda abstraction.
We also do not lift if the function has an occurrence with no arguments, e.g.
-
- let
- f = \x -> e
- in f
-
+
+ let
+ f = \x -> e
+ in f
+
as this form is more efficient than if we create a partial application
$f p q r x = e -- Supercombinator
- f p q r
+ f p q r
* Recursive bindings *all* of whose RHSs are lambda abstractions are
lifted iff
- there aren't ``too many'' free variables.
Same reasoning as before for the function-position stuff. The ``too many
- free variable'' part comes from considering the (potentially many)
+ free variable'' part comes from considering the (potentially many)
recursive calls, which may now have lots of free vars.
Recent Observations:
* We do not lambda lift if the function has at least one occurrence
without any arguments. This caused lots of problems. Ex:
h = \ x -> ... let y = ...
- in let let f = \x -> ...y...
- in f
- ==>
+ in let let f = \x -> ...y...
+ in f
+ ==>
f = \y x -> ...y...
h = \ x -> ... let y = ...
- in f y
-
+ in f y
+
now f y is a partial application, so it will be updated, and this
is Bad.
--- NOT RELEVANT FOR STG ----
-* All ``lone'' lambda abstractions are lifted. Notably this means lambda
+* All ``lone'' lambda abstractions are lifted. Notably this means lambda
abstractions:
- in a case alternative: case e of True -> (\x->b)
- in the body of a let: let x=e in (\y->b)
%************************************************************************
\begin{code}
-liftProgram :: SplitUniqSupply -> [PlainStgBinding] -> [PlainStgBinding]
+liftProgram :: UniqSupply -> [StgBinding] -> [StgBinding]
liftProgram us prog = concat (runLM Nothing us (mapLM liftTopBind prog))
-liftTopBind :: PlainStgBinding -> LiftM [PlainStgBinding]
+liftTopBind :: StgBinding -> LiftM [StgBinding]
liftTopBind (StgNonRec id rhs)
= dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
returnLM (getScBinds rhs_info ++ [StgNonRec id rhs'])
\begin{code}
-liftExpr :: PlainStgExpr
- -> LiftM (PlainStgExpr, LiftInfo)
+liftExpr :: StgExpr
+ -> LiftM (StgExpr, LiftInfo)
-liftExpr expr@(StgConApp con args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgPrimApp op args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgCon con args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgPrim op args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgApp (StgLitAtom lit) args lvs) = returnLM (expr, emptyLiftInfo)
-liftExpr expr@(StgApp (StgVarAtom v) args lvs)
+liftExpr expr@(StgApp (StgLitArg lit) args lvs) = returnLM (expr, emptyLiftInfo)
+liftExpr expr@(StgApp (StgVarArg v) args lvs)
= lookup v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to
-- poke these bindings too early!
- returnLM (StgApp (StgVarAtom sc) (map StgVarAtom sc_args ++ args) lvs,
+ returnLM (StgApp (StgVarArg sc) (map StgVarArg sc_args ++ args) lvs,
emptyLiftInfo)
- -- The lvs field is probably wrong, but we reconstruct it
+ -- The lvs field is probably wrong, but we reconstruct it
-- anyway following lambda lifting
liftExpr (StgCase scrut lv1 lv2 uniq alts)
liftExpr (StgLetNoEscape _ _ (StgNonRec binder rhs) body)
= dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
liftExpr body `thenLM` \ (body', body_info) ->
- returnLM (StgLet (StgNonRec binder rhs') body',
- rhs_info `unionLiftInfo` body_info)
+ returnLM (StgLet (StgNonRec binder rhs') body',
+ rhs_info `unionLiftInfo` body_info)
liftExpr (StgLetNoEscape _ _ (StgRec pairs) body)
= liftExpr body `thenLM` \ (body', body_info) ->
| not (isLiftable rhs)
= dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
liftExpr body `thenLM` \ (body', body_info) ->
- returnLM (StgLet (StgNonRec binder rhs') body',
- rhs_info `unionLiftInfo` body_info)
+ returnLM (StgLet (StgNonRec binder rhs') body',
+ rhs_info `unionLiftInfo` body_info)
| otherwise -- It's a lambda
= -- Do the body of the let
fixLM (\ ~(sc_inline, _, _) ->
addScInlines [binder] [sc_inline] (
- liftExpr body
+ liftExpr body
) `thenLM` \ (body', body_info) ->
-- Deal with the RHS
- dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
+ dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) ->
-- All occurrences in function position, so lambda lift
getFinalFreeVars (rhsFreeVars rhs) `thenLM` \ final_free_vars ->
- mkScPieces final_free_vars (binder,rhs') `thenLM` \ (sc_inline, sc_bind) ->
+ mkScPieces final_free_vars (binder,rhs') `thenLM` \ (sc_inline, sc_bind) ->
- returnLM (sc_inline,
- body',
+ returnLM (sc_inline,
+ body',
nonRecScBind rhs_info sc_bind `unionLiftInfo` body_info)
) `thenLM` \ (_, expr', final_info) ->
returnLM (expr', final_info)
liftExpr (StgLet (StgRec pairs) body)
---[Andre-testing]
+--[Andre-testing]
| not (all isLiftableRec rhss)
= liftExpr body `thenLM` \ (body', body_info) ->
mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) ->
liftExpr body `thenLM` \ (body', body_info) ->
mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) ->
let
- -- Find the free vars of all the rhss,
+ -- Find the free vars of all the rhss,
-- excluding the binders themselves.
rhs_free_vars = unionManyUniqSets (map rhsFreeVars rhss)
- `minusUniqSet`
- mkUniqSet binders
+ `minusUniqSet`
+ mkUniqSet binders
rhs_info = unionLiftInfos rhs_infos
in
mapAndUnzipLM (mkScPieces final_free_vars) (binders `zip` rhss')
`thenLM` \ (sc_inlines, sc_pairs) ->
- returnLM (sc_inlines,
- body',
+ returnLM (sc_inlines,
+ body',
recScBind rhs_info sc_pairs `unionLiftInfo` body_info)
)) `thenLM` \ (_, expr', final_info) ->
occurs in an argument position.
\begin{code}
-isLiftable :: PlainStgRhs -> Bool
+isLiftable :: StgRhs -> Bool
-isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
+isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
-- Experimental evidence suggests we should lift only if we will be
-- abstracting up to 4 fvs.
unapplied_occ || -- Has an occ with no args at all
arg_occ || -- Occurs in arg position
length fvs > 4 -- Too many free variables
- )
+ )
then {-trace ("LL: " ++ show (length fvs))-} True
else False
isLiftable other_rhs = False
-isLiftableRec :: PlainStgRhs -> Bool
+isLiftableRec :: StgRhs -> Bool
-- this is just the same as for non-rec, except we only lift to
-- abstract up to 1 argument this avoids undoing Static Argument
{- Andre's longer comment about isLiftableRec: 1996/01:
-A rec binding is "liftable" (according to our heuristics) if:
-* It is a function,
-* all occurrences have arguments,
+A rec binding is "liftable" (according to our heuristics) if:
+* It is a function,
+* all occurrences have arguments,
* does not occur in an argument position and
* has up to *2* free variables (including the rec binding variable
itself!)
here).
-}
-isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
+isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _)
= if not (null args || -- Not a function
unapplied_occ || -- Has an occ with no args at all
arg_occ || -- Occurs in arg position
length fvs > 2 -- Too many free variables
- )
+ )
then {-trace ("LLRec: " ++ show (length fvs))-} True
else False
isLiftableRec other_rhs = False
-rhsFreeVars :: PlainStgRhs -> IdSet
+rhsFreeVars :: StgRhs -> IdSet
rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkUniqSet fvs
rhsFreeVars other = panic "rhsFreeVars"
\end{code}
ones or mutually-recursive ones where not all are lambdas.
\begin{code}
-dontLiftRhs :: PlainStgRhs -> LiftM (PlainStgRhs, LiftInfo)
+dontLiftRhs :: StgRhs -> LiftM (StgRhs, LiftInfo)
dontLiftRhs rhs@(StgRhsCon cc v args) = returnLM (rhs, emptyLiftInfo)
-dontLiftRhs (StgRhsClosure cc bi fvs upd args body)
+dontLiftRhs (StgRhsClosure cc bi fvs upd args body)
= liftExpr body `thenLM` \ (body', body_info) ->
returnLM (StgRhsClosure cc bi fvs upd args body', body_info)
\end{code}
\begin{code}
mkScPieces :: IdSet -- Extra args for the supercombinator
- -> (Id, PlainStgRhs) -- The processed RHS and original Id
+ -> (Id, StgRhs) -- The processed RHS and original Id
-> LiftM ((Id,[Id]), -- Replace abstraction with this;
-- the set is its free vars
- (Id,PlainStgRhs)) -- Binding for supercombinator
+ (Id,StgRhs)) -- Binding for supercombinator
mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body)
= ASSERT( n_args > 0 )
arity = n_args + length extra_args
-- Construct the supercombinator type
- type_of_original_id = getIdUniType id
- extra_arg_tys = map getIdUniType extra_args
+ type_of_original_id = idType id
+ extra_arg_tys = map idType extra_args
(tyvars, rest) = splitForalls type_of_original_id
sc_ty = mkForallTy tyvars (glueTyArgs extra_arg_tys rest)
\begin{code}
type LiftM a = LiftFlags
- -> SplitUniqSupply
+ -> UniqSupply
-> (IdEnv -- Domain = candidates for lifting
(Id, -- The supercombinator
- [Id]) -- Args to apply it to
+ [Id]) -- Args to apply it to
)
-> a
-- binding; Nothing == infinity
-runLM :: LiftFlags -> SplitUniqSupply -> LiftM a -> a
+runLM :: LiftFlags -> UniqSupply -> LiftM a -> a
runLM flags us m = m flags us nullIdEnv
thenLM :: LiftM a -> (a -> LiftM b) -> LiftM b
\end{code}
\begin{code}
-newSupercombinator :: UniType
+newSupercombinator :: Type
-> Int -- Arity
-> LiftM Id
`addIdArity` arity
-- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it?
where
- uniq = getSUnique us
-
+ uniq = getUnique us
+
lookup :: Id -> LiftM (Id,[Id])
-lookup v ci us idenv
+lookup v ci us idenv
= case lookupIdEnv idenv v of
Just result -> result
Nothing -> (v, [])
getFinalFreeVars :: IdSet -> LiftM IdSet
-getFinalFreeVars free_vars ci us idenv
+getFinalFreeVars free_vars ci us idenv
= unionManyUniqSets (map munge_it (uniqSetToList free_vars))
where
munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real"
munge_it id = case lookupIdEnv idenv id of
Just (_, args) -> mkUniqSet args
Nothing -> singletonUniqSet id
-
+
\end{code}
%************************************************************************
\begin{code}
-type LiftInfo = Bag PlainStgBinding -- Float to top
+type LiftInfo = Bag StgBinding -- Float to top
emptyLiftInfo = emptyBag
-
+
unionLiftInfo :: LiftInfo -> LiftInfo -> LiftInfo
unionLiftInfo binds1 binds2 = binds1 `unionBags` binds2
unionLiftInfos :: [LiftInfo] -> LiftInfo
unionLiftInfos infos = foldr unionLiftInfo emptyLiftInfo infos
-mkScInfo :: PlainStgBinding -> LiftInfo
+mkScInfo :: StgBinding -> LiftInfo
mkScInfo bind = unitBag bind
nonRecScBind :: LiftInfo -- From body of supercombinator
- -> (Id, PlainStgRhs) -- Supercombinator and its rhs
+ -> (Id, StgRhs) -- Supercombinator and its rhs
-> LiftInfo
nonRecScBind binds (sc_id,sc_rhs) = binds `snocBag` (StgNonRec sc_id sc_rhs)
-- So we flatten the whole lot into a single recursive group.
recScBind :: LiftInfo -- From body of supercombinator
- -> [(Id,PlainStgRhs)] -- Supercombinator rhs
+ -> [(Id,StgRhs)] -- Supercombinator rhs
-> LiftInfo
recScBind binds pairs = unitBag (co_rec_ify (StgRec pairs : bagToList binds))
-co_rec_ify :: [PlainStgBinding] -> PlainStgBinding
+co_rec_ify :: [StgBinding] -> StgBinding
co_rec_ify binds = StgRec (concat (map f binds))
where
f (StgNonRec id rhs) = [(id,rhs)]
f (StgRec pairs) = pairs
-getScBinds :: LiftInfo -> [PlainStgBinding]
+getScBinds :: LiftInfo -> [StgBinding]
getScBinds binds = bagToList binds
-looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ ls _)] (StgApp (StgVarAtom f') args _)
+looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ ls _)] (StgApp (StgVarArg f') args _)
= (f == f') && (length args == length ls)
looksLikeSATRhs _ _ = False
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SatStgRhs where
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgBinding)
-satStgRhs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id]
-
import StgSyn
-import AbsUniType ( splitTypeWithDictsAsArgs, Class,
+import Type ( splitTypeWithDictsAsArgs, Class,
TyVarTemplate, TauType(..)
)
import CostCentre
-import IdEnv
-import Id ( mkSysLocal, getIdUniType, getIdArity, addIdArity )
+import Id ( mkSysLocal, idType, getIdArity, addIdArity )
import IdInfo -- SIGH: ( arityMaybe, ArityInfo, OptIdInfo(..) )
import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import SplitUniq
-import Unique
+import UniqSupply
import Util
import Maybes
type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed
-- arity of n
-- Nothing => Don't know how many args it needs
-
+
type Id_w_Arity = Id -- An Id with correct arity info pinned on it
type SatEnv = IdEnv Id_w_Arity -- Binds only local, let(rec)-bound things
\end{code}
-This pass
+This pass
\begin{itemize}
\item adds extra args where necessary;
\item pins the correct arity on everything.
%************************************************************************
\begin{code}
-satStgRhs :: PlainStgProgram -> SUniqSM PlainStgProgram
+satStgRhs :: [StgBinding] -> UniqSM [StgBinding]
satStgRhs p = satProgram nullIdEnv p
-satProgram :: SatEnv -> PlainStgProgram -> SUniqSM PlainStgProgram
-satProgram env [] = returnSUs []
+satProgram :: SatEnv -> [StgBinding] -> UniqSM [StgBinding]
+satProgram env [] = returnUs []
-satProgram env (bind:binds)
- = satBinding True{-toplevel-} env bind `thenSUs` \ (env2, bind2) ->
- satProgram env2 binds `thenSUs` \ binds2 ->
- returnSUs (bind2 : binds2)
+satProgram env (bind:binds)
+ = satBinding True{-toplevel-} env bind `thenUs` \ (env2, bind2) ->
+ satProgram env2 binds `thenUs` \ binds2 ->
+ returnUs (bind2 : binds2)
\end{code}
%************************************************************************
\begin{code}
satBinding :: Bool -- True <=> top-level
- -> SatEnv
- -> PlainStgBinding
- -> SUniqSM (SatEnv, PlainStgBinding)
+ -> SatEnv
+ -> StgBinding
+ -> UniqSM (SatEnv, StgBinding)
satBinding top env (StgNonRec b rhs)
- = satRhs top env (b, rhs) `thenSUs` \ (b2, rhs2) ->
+ = satRhs top env (b, rhs) `thenUs` \ (b2, rhs2) ->
let
env2 = addOneToIdEnv env b b2
in
- returnSUs (env2, StgNonRec b2 rhs2)
+ returnUs (env2, StgNonRec b2 rhs2)
satBinding top env (StgRec pairs)
= -- Do it once to get the arities right...
- mapSUs (satRhs top env) pairs `thenSUs` \ pairs2 ->
+ mapUs (satRhs top env) pairs `thenUs` \ pairs2 ->
let
env2 = growIdEnvList env (map fst pairs `zip` map fst pairs2)
in
-- Do it again to *use* those arities:
- mapSUs (satRhs top env2) pairs `thenSUs` \ pairs3 ->
+ mapUs (satRhs top env2) pairs `thenUs` \ pairs3 ->
- returnSUs (env2, StgRec pairs3)
+ returnUs (env2, StgRec pairs3)
-satRhs :: Bool -> SatEnv -> (Id, PlainStgRhs) -> SUniqSM (Id_w_Arity, PlainStgRhs)
+satRhs :: Bool -> SatEnv -> (Id, StgRhs) -> UniqSM (Id_w_Arity, StgRhs)
satRhs top env (b, StgRhsCon cc con args) -- Nothing much to do here
- = let
+ = let
b2 = b `addIdArity` 0 -- bound to a saturated constructor; hence zero.
in
- returnSUs (b2, StgRhsCon cc con (lookupArgs env args))
+ returnUs (b2, StgRhsCon cc con (lookupArgs env args))
satRhs top env (b, StgRhsClosure cc bi fv u args body)
- = satExpr env body `thenSUs` \ (arity_info, body2) ->
+ = satExpr env body `thenUs` \ (arity_info, body2) ->
let
num_args = length args
in
(case arity_info of
Nothing ->
- returnSUs (num_args, StgRhsClosure cc bi fv u args body2)
+ returnUs (num_args, StgRhsClosure cc bi fv u args body2)
Just needed_args ->
ASSERT(needed_args >= 1)
new_arity = num_args + needed_args
-- get type info for this function:
- (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (getIdUniType b)
+ (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (idType b)
-- now, we already have "args"; we drop that many types
args_we_dont_have_tys = drop num_args all_arg_tys
args_to_add_tys = take needed_args args_we_dont_have_tys
in
-- make up names for them
- mapSUs newName args_to_add_tys `thenSUs` \ nns ->
+ mapUs newName args_to_add_tys `thenUs` \ nns ->
-- and do the business
let
- body3 = saturate body2 (map StgVarAtom nns)
+ body3 = saturate body2 (map StgVarArg nns)
new_cc -- if we're adding args, we'd better not
-- keep calling something a CAF! (what about DICTs? ToDo: WDP 95/02)
- = if not (isCafCC cc)
- then cc -- unchanged
+ = if not (isCafCC cc)
+ then cc -- unchanged
else if top then subsumedCosts else useCurrentCostCentre
in
- returnSUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3)
+ returnUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3)
)
- `thenSUs` \ (arity, rhs2) ->
- let
+ `thenUs` \ (arity, rhs2) ->
+ let
b2 = b `addIdArity` arity
in
- returnSUs (b2, rhs2)
+ returnUs (b2, rhs2)
\end{code}
%************************************************************************
%* *
%************************************************************************
-\begin{code}
-satExpr :: SatEnv -> PlainStgExpr -> SUniqSM (ExprArityInfo, PlainStgExpr)
+\begin{code}
+satExpr :: SatEnv -> StgExpr -> UniqSM (ExprArityInfo, StgExpr)
-satExpr env app@(StgApp (StgLitAtom lit) [] lvs) = returnSUs (Nothing, app)
+satExpr env app@(StgApp (StgLitArg lit) [] lvs) = returnUs (Nothing, app)
-satExpr env app@(StgApp (StgVarAtom f) as lvs)
- = returnSUs (arity_to_return, StgApp (StgVarAtom f2) as2 lvs)
+satExpr env app@(StgApp (StgVarArg f) as lvs)
+ = returnUs (arity_to_return, StgApp (StgVarArg f2) as2 lvs)
where
as2 = lookupArgs env as
f2 = lookupVar env f
arity_to_return = case arityMaybe (getIdArity f2) of
Nothing -> Nothing
- Just f_arity -> if remaining_arity > 0
+ Just f_arity -> if remaining_arity > 0
then Just remaining_arity
else Nothing
where
remaining_arity = f_arity - length as
-
-satExpr env app@(StgConApp con as lvs)
- = returnSUs (Nothing, StgConApp con (lookupArgs env as) lvs)
-satExpr env app@(StgPrimApp op as lvs)
- = returnSUs (Nothing, StgPrimApp op (lookupArgs env as) lvs)
+satExpr env app@(StgCon con as lvs)
+ = returnUs (Nothing, StgCon con (lookupArgs env as) lvs)
+
+satExpr env app@(StgPrim op as lvs)
+ = returnUs (Nothing, StgPrim op (lookupArgs env as) lvs)
satExpr env (StgSCC ty l e)
- = satExpr env e `thenSUs` \ (_, e2) ->
- returnSUs (Nothing, StgSCC ty l e2)
+ = satExpr env e `thenUs` \ (_, e2) ->
+ returnUs (Nothing, StgSCC ty l e2)
{- OMITTED: Let-no-escapery should come *after* saturation
satExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
- = satBinding binds `thenSUs` \ (binds2, c) ->
- satExpr body `thenSUs` \ (_, body2, c2) ->
- returnSUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2)
+ = satBinding binds `thenUs` \ (binds2, c) ->
+ satExpr body `thenUs` \ (_, body2, c2) ->
+ returnUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2)
-}
satExpr env (StgLet binds body)
- = satBinding False{-not top-level-} env binds `thenSUs` \ (env2, binds2) ->
- satExpr env2 body `thenSUs` \ (_, body2) ->
- returnSUs (Nothing, StgLet binds2 body2)
+ = satBinding False{-not top-level-} env binds `thenUs` \ (env2, binds2) ->
+ satExpr env2 body `thenUs` \ (_, body2) ->
+ returnUs (Nothing, StgLet binds2 body2)
satExpr env (StgCase expr lve lva uniq alts)
- = satExpr env expr `thenSUs` \ (_, expr2) ->
- sat_alts alts `thenSUs` \ alts2 ->
- returnSUs (Nothing, StgCase expr2 lve lva uniq alts2)
+ = satExpr env expr `thenUs` \ (_, expr2) ->
+ sat_alts alts `thenUs` \ alts2 ->
+ returnUs (Nothing, StgCase expr2 lve lva uniq alts2)
where
sat_alts (StgAlgAlts ty alts def)
- = mapSUs sat_alg_alt alts `thenSUs` \ alts2 ->
- sat_deflt def `thenSUs` \ def2 ->
- returnSUs (StgAlgAlts ty alts2 def2)
+ = mapUs sat_alg_alt alts `thenUs` \ alts2 ->
+ sat_deflt def `thenUs` \ def2 ->
+ returnUs (StgAlgAlts ty alts2 def2)
where
sat_alg_alt (id, bs, use_mask, e)
- = satExpr env e `thenSUs` \ (_, e2) ->
- returnSUs (id, bs, use_mask, e2)
+ = satExpr env e `thenUs` \ (_, e2) ->
+ returnUs (id, bs, use_mask, e2)
sat_alts (StgPrimAlts ty alts def)
- = mapSUs sat_prim_alt alts `thenSUs` \ alts2 ->
- sat_deflt def `thenSUs` \ def2 ->
- returnSUs (StgPrimAlts ty alts2 def2)
+ = mapUs sat_prim_alt alts `thenUs` \ alts2 ->
+ sat_deflt def `thenUs` \ def2 ->
+ returnUs (StgPrimAlts ty alts2 def2)
where
sat_prim_alt (l, e)
- = satExpr env e `thenSUs` \ (_, e2) ->
- returnSUs (l, e2)
+ = satExpr env e `thenUs` \ (_, e2) ->
+ returnUs (l, e2)
sat_deflt StgNoDefault
- = returnSUs StgNoDefault
+ = returnUs StgNoDefault
sat_deflt (StgBindDefault b u expr)
- = satExpr env expr `thenSUs` \ (_,expr2) ->
- returnSUs (StgBindDefault b u expr2)
+ = satExpr env expr `thenUs` \ (_,expr2) ->
+ returnUs (StgBindDefault b u expr2)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-saturate :: PlainStgExpr -> [PlainStgAtom] -> PlainStgExpr
+saturate :: StgExpr -> [StgArg] -> StgExpr
saturate (StgApp f as lvs) ids = StgApp f (as ++ ids) lvs
saturate other _ = panic "SatStgRhs: saturate"
\end{code}
\begin{code}
-lookupArgs :: SatEnv -> [PlainStgAtom] -> [PlainStgAtom]
+lookupArgs :: SatEnv -> [StgArg] -> [StgArg]
lookupArgs env args = map do args
- where
- do (StgVarAtom v) = StgVarAtom (lookupVar env v)
- do a@(StgLitAtom lit) = a
+ where
+ do (StgVarArg v) = StgVarArg (lookupVar env v)
+ do a@(StgLitArg lit) = a
lookupVar :: SatEnv -> Id -> Id
lookupVar env v = case lookupIdEnv env v of
Nothing -> v
Just v2 -> v2
-newName :: UniType -> SUniqSM Id
+newName :: Type -> UniqSM Id
newName ut
- = getSUnique `thenSUs` \ uniq ->
- returnSUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc)
+ = getUnique `thenUs` \ uniq ->
+ returnUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SimplStg where
-import CmdLineOpts(GlobalSwitch, StgToDo, SwitchResult)
-import CostCentre(CostCentre)
-import Id(Id)
-import PreludePS(_PackedString)
-import Pretty(PprStyle)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgBinding)
-stg2stg :: [StgToDo] -> (GlobalSwitch -> SwitchResult) -> _PackedString -> PprStyle -> SplitUniqSupply -> [StgBinding Id Id] -> _State _RealWorld -> (([StgBinding Id Id], ([CostCentre], [CostCentre])), _State _RealWorld)
-
IMPORT_Trace
import StgSyn
-import StgFuns
+import StgUtils
import LambdaLift ( liftProgram )
import SCCfinal ( stgMassageForProfiling )
import CmdLineOpts
import Id ( unlocaliseId )
-import IdEnv
import MainMonad
import Maybes ( maybeToBool, Maybe(..) )
import Outputable
import Pretty
-import SplitUniq
import StgLint ( lintStgBindings )
import StgSAT ( doStaticArgs )
import UniqSet
-import Unique
+import UniqSupply
import Util
\end{code}
-> (GlobalSwitch -> SwitchResult)-- access to all global cmd-line opts
-> FAST_STRING -- module name (profiling only)
-> PprStyle -- printing style (for debugging only)
- -> SplitUniqSupply -- a name supply
- -> [PlainStgBinding] -- input...
+ -> UniqSupply -- a name supply
+ -> [StgBinding] -- input...
-> MainIO
- ([PlainStgBinding], -- output program...
+ ([StgBinding], -- output program...
([CostCentre], -- local cost-centres that need to be decl'd
[CostCentre])) -- "extern" cost-centres
(if do_verbose_stg2stg then
writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
- writeMn stderr (ppShow 1000
+ writeMn stderr (ppShow 1000
(ppAbove (ppStr ("*** Core2Stg:"))
(ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
))
-- info. Also, setStgVarInfo decides about let-no-escape
-- things, which in turn do a better job if arities are
-- correct, which is done by satStgRhs.
- --
+ --
let
-- ToDo: provide proper flag control!
binds_to_mangle
end_pass us2 what ccs binds2
= -- report verbosely, if required
(if do_verbose_stg2stg then
- writeMn stderr (ppShow 1000
+ writeMn stderr (ppShow 1000
(ppAbove (ppStr ("*** "++what++":"))
(ppAboves (map (ppr ppr_style) binds2))
))
Nothing -> id
Just new_id -> new_id
-unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [PlainStgBinding] -> (UnlocalEnv, [PlainStgBinding])
+unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
unlocaliseStgBinds mod uenv [] = (uenv, [])
------------------
-unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> PlainStgBinding -> (UnlocalEnv, PlainStgBinding)
+unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
unlocal_top_bind mod uenv bind@(StgNonRec binder _)
= let new_uenv = case unlocaliseId mod binder of
unlocal_top_bind mod uenv bind@(StgRec pairs)
= let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
- new_uenv = growIdEnvList uenv [ (b,new_b)
+ new_uenv = growIdEnvList uenv [ (b,new_b)
| (b, Just new_b) <- maybe_unlocaliseds]
in
(new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
Then blast the whole program (LHSs as well as RHSs) with it.
\begin{code}
-elimIndirections :: [PlainStgBinding] -> [PlainStgBinding]
+elimIndirections :: [StgBinding] -> [StgBinding]
elimIndirections binds_in
= if isNullIdEnv blast_env then
(blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
- try_bind :: IdEnv Id -> PlainStgBinding -> (IdEnv Id, Maybe PlainStgBinding)
- try_bind env_so_far
- (StgNonRec exported_binder
- (StgRhsClosure _ _ _ _
+ try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
+ try_bind env_so_far
+ (StgNonRec exported_binder
+ (StgRhsClosure _ _ _ _
lambda_args
- (StgApp (StgVarAtom local_binder) fun_args _)
+ (StgApp (StgVarArg local_binder) fun_args _)
))
| isExported exported_binder && -- Only if this is exported
not (isExported local_binder) && -- Only if this one is defined in this
= (addOneToIdEnv env_so_far local_binder exported_binder,
Nothing)
- where
+ where
args_match [] [] = True
- args_match (la:las) (StgVarAtom fa:fas) = la == fa && args_match las fas
+ args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
args_match _ _ = False
- try_bind env_so_far bind
+ try_bind env_so_far bind
= (env_so_far, Just bind)
in_dom env id = maybeToBool (lookupIdEnv env id)
@renameTopStgBind@ renames top level binders and all occurrences thereof.
\begin{code}
-renameTopStgBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding
+renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgSAT where
-import CostCentre(CostCentre)
-import Id(Id)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(PlainStgProgram(..), StgAtom, StgBinding, StgCaseAlternatives, StgExpr, StgRhs)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Id
-type PlainStgProgram = [StgBinding Id Id]
-data StgBinding a b
-data StgExpr a b
-doStaticArgs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
\begin{code}
#include "HsVersions.h"
-module StgSAT (
- doStaticArgs,
+module StgSAT ( doStaticArgs ) where
- -- and to make the interface self-sufficient...
- PlainStgProgram(..), StgExpr, StgBinding, Id
- ) where
-
-import IdEnv
import Maybes ( Maybe(..) )
import StgSyn
import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv,
- SatM(..), initSAT, thenSAT, thenSAT_,
- emptyEnvSAT, returnSAT, mapSAT )
+ SatM(..), initSAT, thenSAT, thenSAT_,
+ emptyEnvSAT, returnSAT, mapSAT )
import StgSATMonad
-import SplitUniq
+import UniqSupply
import Util
\end{code}
\begin{code}
-doStaticArgs :: PlainStgProgram -> SplitUniqSupply -> PlainStgProgram
+doStaticArgs :: [StgBinding] -> UniqSupply -> [StgBinding]
doStaticArgs binds
= initSAT (mapSAT sat_bind binds)
\end{code}
\begin{code}
-satAtom (StgVarAtom v)
+satAtom (StgVarArg v)
= updSAEnv (Just (v,([],[]))) `thenSAT_`
returnSAT ()
\end{code}
\begin{code}
-satExpr :: PlainStgExpr -> SatM PlainStgExpr
+satExpr :: StgExpr -> SatM StgExpr
-satExpr e@(StgConApp con args lvs)
+satExpr e@(StgCon con args lvs)
= mapSAT satAtom args `thenSAT_`
returnSAT e
-satExpr e@(StgPrimApp op args lvs)
+satExpr e@(StgPrim op args lvs)
= mapSAT satAtom args `thenSAT_`
returnSAT e
-satExpr e@(StgApp (StgLitAtom _) _ _)
+satExpr e@(StgApp (StgLitArg _) _ _)
= returnSAT e
-satExpr e@(StgApp (StgVarAtom v) args _)
+satExpr e@(StgApp (StgVarArg v) args _)
= updSAEnv (Just (v,([],map tagArg args))) `thenSAT_`
mapSAT satAtom args `thenSAT_`
returnSAT e
- where
- tagArg (StgVarAtom v) = Static v
+ where
+ tagArg (StgVarArg v) = Static v
tagArg _ = NotStatic
-
+
satExpr (StgCase expr lv1 lv2 uniq alts)
= satExpr expr `thenSAT` \ expr' ->
sat_alts alts `thenSAT` \ alts' ->
satExpr (StgSCC ty cc expr)
= satExpr expr `thenSAT` \ expr' ->
returnSAT (StgSCC ty cc expr')
-
--- ToDo: DPH stuff
\end{code}
\begin{code}
satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs
-satRhs (StgRhsClosure cc bi fvs upd args body)
+
+satRhs (StgRhsClosure cc bi fvs upd args body)
= satExpr body `thenSAT` \ body' ->
returnSAT (StgRhsClosure cc bi fvs upd args body')
-
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgSATMonad where
-import Id(Id)
-import SATMonad(Arg)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(PlainStgExpr(..), StgBinding, StgExpr, StgRhs)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data Id
-data SplitUniqSupply
-type PlainStgExpr = StgExpr Id Id
-data UniType
-getArgLists :: StgRhs Id Id -> ([Arg UniType], [Arg Id])
-saTransform :: Id -> StgRhs Id Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (StgBinding Id Id, UniqFM ([Arg UniType], [Arg Id]))
-
#include "HsVersions.h"
module StgSATMonad (
- getArgLists, saTransform,
-
- Id, UniType, SplitUniqSupply, PlainStgExpr(..)
+ getArgLists, saTransform
) where
-import AbsUniType ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
- extractTyVarsFromTy, splitType, splitTyArgs,
+import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
+ extractTyVarsFromTy, splitSigmaTy, splitTyArgs,
glueTyArgs, instantiateTy, TauType(..),
Class, ThetaType(..), SigmaType(..),
InstTyEnv(..)
)
-import IdEnv
-import Id ( mkSysLocal, getIdUniType, eqId )
+import Id ( mkSysLocal, idType, eqId )
import Maybes ( Maybe(..) )
import StgSyn
import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv,
- SatM(..), initSAT, thenSAT, thenSAT_,
- emptyEnvSAT, returnSAT, mapSAT, isStatic, dropStatics,
- getSATInfo, newSATName )
+ SatM(..), initSAT, thenSAT, thenSAT_,
+ emptyEnvSAT, returnSAT, mapSAT, isStatic, dropStatics,
+ getSATInfo, newSATName )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
-import SplitUniq
-import Unique
+import UniqSupply
import UniqSet ( UniqSet(..), emptyUniqSet )
import Util
\begin{code}
newSATNames :: [Id] -> SatM [Id]
newSATNames [] = returnSAT []
-newSATNames (id:ids) = newSATName id (getIdUniType id) `thenSAT` \ id' ->
- newSATNames ids `thenSAT` \ ids' ->
- returnSAT (id:ids)
+newSATNames (id:ids) = newSATName id (idType id) `thenSAT` \ id' ->
+ newSATNames ids `thenSAT` \ ids' ->
+ returnSAT (id:ids)
-getArgLists :: PlainStgRhs -> ([Arg UniType],[Arg Id])
-getArgLists (StgRhsCon _ _ _)
+getArgLists :: StgRhs -> ([Arg Type],[Arg Id])
+getArgLists (StgRhsCon _ _ _)
= ([],[])
getArgLists (StgRhsClosure _ _ _ _ args _)
= ([], [Static v | v <- args])
\end{code}
\begin{code}
-saTransform :: Id -> PlainStgRhs -> SatM PlainStgBinding
+saTransform :: Id -> StgRhs -> SatM StgBinding
saTransform binder rhs
= getSATInfo binder `thenSAT` \ r ->
case r of
- Just (_,args) | any isStatic args
+ Just (_,args) | any isStatic args
-- [Andre] test: do it only if we have more than one static argument.
--Just (_,args) | length (filter isStatic args) > 1
-> newSATName binder (new_ty args) `thenSAT` \ binder' ->
- let non_static_args = get_nsa args (snd (getArgLists rhs))
- in
+ let non_static_args = get_nsa args (snd (getArgLists rhs))
+ in
newSATNames non_static_args `thenSAT` \ non_static_args' ->
mkNewRhs binder binder' args rhs non_static_args' non_static_args
`thenSAT` \ new_rhs ->
trace ("SAT(STG) "++ show (length (filter isStatic args))) (
- returnSAT (StgNonRec binder new_rhs)
- )
+ returnSAT (StgNonRec binder new_rhs)
+ )
_ -> returnSAT (StgRec [(binder, rhs)])
where
mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args
= let
- local_body = StgApp (StgVarAtom binder')
- [StgVarAtom a | a <- non_static_args] emptyUniqSet
+ local_body = StgApp (StgVarArg binder')
+ [StgVarArg a | a <- non_static_args] emptyUniqSet
rec_body = StgRhsClosure cc bi fvs upd non_static_args'
- (doStgSubst binder args subst_env body)
+ (doStgSubst binder args subst_env body)
- subst_env = mkIdEnv
- ((binder,binder'):zip non_static_args non_static_args')
+ subst_env = mkIdEnv
+ ((binder,binder'):zip non_static_args non_static_args')
in
returnSAT (
- StgRhsClosure cc bi fvs upd rhsargs
+ StgRhsClosure cc bi fvs upd rhsargs
(StgLet (StgRec [(binder',rec_body)]) {-in-} local_body)
)
= instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty')
where
-- get type info for the local function:
- (tv_tmpl, dict_tys, tau_ty) = (splitType . getIdUniType) binder
+ (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
(reg_arg_tys, res_type) = splitTyArgs tau_ty
-- now, we drop the ones that are
\begin{code}
doStgSubst binder orig_args subst_env body
= substExpr body
- where
- substExpr (StgConApp con args lvs)
- = StgConApp con (map substAtom args) emptyUniqSet
- substExpr (StgPrimApp op args lvs)
- = StgPrimApp op (map substAtom args) emptyUniqSet
- substExpr expr@(StgApp (StgLitAtom _) [] _)
+ where
+ substExpr (StgCon con args lvs)
+ = StgCon con (map substAtom args) emptyUniqSet
+ substExpr (StgPrim op args lvs)
+ = StgPrim op (map substAtom args) emptyUniqSet
+ substExpr expr@(StgApp (StgLitArg _) [] _)
= expr
- substExpr (StgApp atom@(StgVarAtom v) args lvs)
+ substExpr (StgApp atom@(StgVarArg v) args lvs)
| v `eqId` binder
- = StgApp (StgVarAtom (lookupNoFailIdEnv subst_env v))
- (remove_static_args orig_args args) emptyUniqSet
+ = StgApp (StgVarArg (lookupNoFailIdEnv subst_env v))
+ (remove_static_args orig_args args) emptyUniqSet
| otherwise
= StgApp (substAtom atom) (map substAtom args) lvs
substExpr (StgCase scrut lv1 lv2 uniq alts)
= StgCase (substExpr scrut) emptyUniqSet emptyUniqSet uniq (subst_alts alts)
where
- subst_alts (StgAlgAlts ty alg_alts deflt)
- = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt)
- subst_alts (StgPrimAlts ty prim_alts deflt)
- = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt)
- subst_alg_alt (con, args, use_mask, rhs)
- = (con, args, use_mask, substExpr rhs)
- subst_prim_alt (lit, rhs)
- = (lit, substExpr rhs)
- subst_deflt StgNoDefault
- = StgNoDefault
- subst_deflt (StgBindDefault var used rhs)
- = StgBindDefault var used (substExpr rhs)
+ subst_alts (StgAlgAlts ty alg_alts deflt)
+ = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt)
+ subst_alts (StgPrimAlts ty prim_alts deflt)
+ = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt)
+ subst_alg_alt (con, args, use_mask, rhs)
+ = (con, args, use_mask, substExpr rhs)
+ subst_prim_alt (lit, rhs)
+ = (lit, substExpr rhs)
+ subst_deflt StgNoDefault
+ = StgNoDefault
+ subst_deflt (StgBindDefault var used rhs)
+ = StgBindDefault var used (substExpr rhs)
substExpr (StgLetNoEscape fv1 fv2 b body)
= StgLetNoEscape emptyUniqSet emptyUniqSet (substBinding b) (substExpr body)
substExpr (StgLet b body)
= StgLet (substBinding b) (substExpr body)
substExpr (StgSCC ty cc expr)
= StgSCC ty cc (substExpr expr)
- substRhs (StgRhsCon cc v args)
+ substRhs (StgRhsCon cc v args)
= StgRhsCon cc v (map substAtom args)
substRhs (StgRhsClosure cc bi fvs upd args body)
= StgRhsClosure cc bi [] upd args (substExpr body)
-
+
substBinding (StgNonRec binder rhs)
= StgNonRec binder (substRhs rhs)
substBinding (StgRec pairs)
= StgRec (zip binders (map substRhs rhss))
where
- (binders,rhss) = unzip pairs
-
- substAtom atom@(StgLitAtom lit) = atom
- substAtom atom@(StgVarAtom v)
+ (binders,rhss) = unzip pairs
+
+ substAtom atom@(StgLitArg lit) = atom
+ substAtom atom@(StgVarArg v)
= case lookupIdEnv subst_env v of
- Just v' -> StgVarAtom v'
- Nothing -> atom
-
- remove_static_args _ []
+ Just v' -> StgVarArg v'
+ Nothing -> atom
+
+ remove_static_args _ []
= []
- remove_static_args (Static _:origs) (_:as)
+ remove_static_args (Static _:origs) (_:as)
= remove_static_args origs as
- remove_static_args (NotStatic:origs) (a:as)
+ remove_static_args (NotStatic:origs) (a:as)
= substAtom a:remove_static_args origs as
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgStats where
-import Id(Id)
-import StgSyn(StgBinding)
-showStgStats :: [StgBinding Id Id] -> [Char]
-
%************************************************************************
\begin{code}
-showStgStats :: PlainStgProgram -> String
+showStgStats :: [StgBinding] -> String
showStgStats prog
= "STG Statistics:\n\n"
s (SingleEntryBinds _) = "SingleEntryBinds_Nested "
s (UpdatableBinds _) = "UpdatableBinds_Nested "
-gatherStgStats :: PlainStgProgram -> StatEnv
+gatherStgStats :: [StgBinding] -> StatEnv
-gatherStgStats binds
+gatherStgStats binds
= combineSEs (map (statBinding True{-top-level-}) binds)
\end{code}
\begin{code}
statBinding :: Bool -- True <=> top-level; False <=> nested
- -> PlainStgBinding
+ -> StgBinding
-> StatEnv
statBinding top (StgNonRec b rhs)
statBinding top (StgRec pairs)
= combineSEs (map (statRhs top) pairs)
-statRhs :: Bool -> (Id, PlainStgRhs) -> StatEnv
+statRhs :: Bool -> (Id, StgRhs) -> StatEnv
statRhs top (b, StgRhsCon cc con args)
= countOne (ConstructorBinds top)
statRhs top (b, StgRhsClosure cc bi fv u args body)
- = statExpr body `combineSE`
+ = statExpr body `combineSE`
countN FreeVariables (length fv) `combineSE`
countOne (
case u of
%* *
%************************************************************************
-\begin{code}
-statExpr :: PlainStgExpr -> StatEnv
+\begin{code}
+statExpr :: StgExpr -> StatEnv
-statExpr (StgApp _ [] lvs)
+statExpr (StgApp _ [] lvs)
= countOne Literals
-statExpr (StgApp _ _ lvs)
+statExpr (StgApp _ _ lvs)
= countOne Applications
-statExpr (StgConApp con as lvs)
+statExpr (StgCon con as lvs)
= countOne ConstructorApps
-statExpr (StgPrimApp op as lvs)
+statExpr (StgPrim op as lvs)
= countOne PrimitiveApps
statExpr (StgSCC ty l e)
statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
= statBinding False{-not top-level-} binds `combineSE`
- statExpr body `combineSE`
+ statExpr body `combineSE`
countOne LetNoEscapes
statExpr (StgLet binds body)
- = statBinding False{-not top-level-} binds `combineSE`
+ = statBinding False{-not top-level-} binds `combineSE`
statExpr body
statExpr (StgCase expr lve lva uniq alts)
where
stat_alts (StgAlgAlts ty alts def)
= combineSEs (map statExpr [ e | (_,_,_,e) <- alts ])
- `combineSE`
+ `combineSE`
stat_deflt def `combineSE`
countOne AlgCases
stat_deflt StgNoDefault = emptySE
- stat_deflt (StgBindDefault b u expr) = statExpr expr
+ stat_deflt (StgBindDefault b u expr) = statExpr expr
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgVarInfo where
-import Id(Id)
-import StgSyn(StgBinding)
-setStgVarInfo :: Bool -> [StgBinding Id Id] -> [StgBinding Id Id]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[StgVarInfo]{Sets free/live variable info in STG syntax}
import Id ( getIdArity, externallyVisibleId )
import IdInfo -- ( arityMaybe, ArityInfo )
-import IdEnv
import Maybes ( maybeToBool, Maybe(..) )
import UniqSet
import Util
variable's stack slot (if it has one):
\begin{enumerate}
\item
-should be stubbed to avoid space leaks, and
+should be stubbed to avoid space leaks, and
\item
may be reused for something else.
\end{enumerate}
There ought to be a better way to say this. Here are some examples:
\begin{verbatim}
let v = [q] \[x] -> e
- in
+ in
...v... (but no q's)
\end{verbatim}
Just after the `in', v is live, but q is dead. If the whole of that
let expression was enclosed in a case expression, thus:
\begin{verbatim}
- case (let v = [q] \[x] -> e in ...v...) of
+ case (let v = [q] \[x] -> e in ...v...) of
alts[...q...]
\end{verbatim}
(ie @alts@ mention @q@), then @q@ is live even after the `in'; because
Let-no-escapes make this a bit more interesting:
\begin{verbatim}
let-no-escape v = [q] \ [x] -> e
- in
+ in
...v...
\end{verbatim}
Here, @q@ is still live at the `in', because @v@ is represented not by
Top-level:
\begin{code}
setStgVarInfo :: Bool -- True <=> do let-no-escapes
- -> [PlainStgBinding] -- input
- -> [PlainStgBinding] -- result
+ -> [StgBinding] -- input
+ -> [StgBinding] -- result
-setStgVarInfo want_LNEs pgm
- = pgm'
+setStgVarInfo want_LNEs pgm
+ = pgm'
where
(pgm', _) = initLne want_LNEs (varsTopBinds pgm)
-
+
\end{code}
For top-level guys, we basically aren't worried about this
as we step through the bindings (using @extendVarEnv@).
\begin{code}
-varsTopBinds :: [PlainStgBinding] -> LneM ([PlainStgBinding], FreeVarsInfo)
+varsTopBinds :: [StgBinding] -> LneM ([StgBinding], FreeVarsInfo)
varsTopBinds [] = returnLne ([], emptyFVInfo)
varsTopBinds (bind:binds)
returnLne ((bind' : binds'),
(fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders
)
-
+
)
where
- env_extension = [(b, LetrecBound
+ env_extension = [(b, LetrecBound
True {- top level -}
(rhsArity rhs)
emptyUniqSet)
varsTopBind :: FreeVarsInfo -- Info about the body
- -> PlainStgBinding
- -> LneM (PlainStgBinding, FreeVarsInfo)
+ -> StgBinding
+ -> LneM (StgBinding, FreeVarsInfo)
varsTopBind body_fvs (StgNonRec binder rhs)
= varsRhs body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
(binders, rhss) = unzip pairs
in
fixLne (\ ~(_, rec_rhs_fvs) ->
- let
+ let
scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
in
mapAndUnzip3Lne (varsRhs scope_fvs) pairs `thenLne` \ (rhss2, fvss, _) ->
\begin{code}
varsRhs :: FreeVarsInfo -- Free var info for the scope of the binding
- -> (Id,PlainStgRhs)
- -> LneM (PlainStgRhs, FreeVarsInfo, EscVarsSet)
+ -> (Id,StgRhs)
+ -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
varsRhs scope_fv_info (binder, StgRhsCon cc con args)
= varsAtoms args `thenLne` \ fvs ->
returnLne (StgRhsCon cc con args, fvs, getFVSet fvs)
-varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body)
+varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body)
= extendVarEnv [ (a, LambdaBound) | a <- args ] (
do_body args body `thenLne` \ (body2, body_fvs, body_escs) ->
let
set_of_args = mkUniqSet args
rhs_fvs = body_fvs `minusFVBinders` args
rhs_escs = body_escs `minusUniqSet` set_of_args
- binder_info = lookupFVInfo scope_fv_info binder
+ binder_info = lookupFVInfo scope_fv_info binder
in
- returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2,
+ returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2,
rhs_fvs, rhs_escs)
)
where
-- Pick out special case of application in body of thunk
- do_body [] (StgApp (StgVarAtom f) args _) = varsApp (Just upd) f args
+ do_body [] (StgApp (StgVarArg f) args _) = varsApp (Just upd) f args
do_body _ other_body = varsExpr other_body
\end{code}
\begin{code}
-varsAtoms :: [PlainStgAtom]
+varsAtoms :: [StgArg]
-> LneM FreeVarsInfo
varsAtoms atoms
= mapLne var_atom atoms `thenLne` \ fvs_lists ->
returnLne (unionFVInfos fvs_lists)
where
- var_atom a@(StgLitAtom _) = returnLne emptyFVInfo
- var_atom a@(StgVarAtom v)
+ var_atom a@(StgLitArg _) = returnLne emptyFVInfo
+ var_atom a@(StgVarArg v)
= lookupVarEnv v `thenLne` \ how_bound ->
returnLne (singletonFVInfo v how_bound stgArgOcc)
\end{code}
@varsExpr@ carries in a monad-ised environment, which binds each
let(rec) variable (ie non top level, not imported, not lambda bound,
not case-alternative bound) to:
- - its STG arity, and
- - its set of live vars.
+ - its STG arity, and
+ - its set of live vars.
For normal variables the set of live vars is just the variable
itself. For let-no-escaped variables, the set of live vars is the set
live at the moment the variable is entered. The set is guaranteed to
have no further let-no-escaped vars in it.
\begin{code}
-varsExpr :: PlainStgExpr
- -> LneM (PlainStgExpr, -- Decorated expr
+varsExpr :: StgExpr
+ -> LneM (StgExpr, -- Decorated expr
FreeVarsInfo, -- Its free vars (NB free, not live)
EscVarsSet) -- Its escapees, a subset of its free vars;
-- also a subset of the domain of the envt
-- because we are only interested in the escapees
- -- for vars which might be turned into
+ -- for vars which might be turned into
-- let-no-escaped ones.
\end{code}
decisions. Hence no black holes.
\begin{code}
-varsExpr (StgApp lit@(StgLitAtom _) args _)
+varsExpr (StgApp lit@(StgLitArg _) args _)
= --(if null args then id else (trace (ppShow 80 (ppr PprShowAll args)))) (
returnLne (StgApp lit [] emptyUniqSet, emptyFVInfo, emptyUniqSet)
--)
-varsExpr (StgApp fun@(StgVarAtom f) args _) = varsApp Nothing f args
+varsExpr (StgApp fun@(StgVarArg f) args _) = varsApp Nothing f args
-varsExpr (StgConApp con args _)
+varsExpr (StgCon con args _)
= getVarsLiveInCont `thenLne` \ live_in_cont ->
varsAtoms args `thenLne` \ args_fvs ->
- returnLne (StgConApp con args live_in_cont, args_fvs, getFVSet args_fvs)
+ returnLne (StgCon con args live_in_cont, args_fvs, getFVSet args_fvs)
-varsExpr (StgPrimApp op args _)
+varsExpr (StgPrim op args _)
= getVarsLiveInCont `thenLne` \ live_in_cont ->
varsAtoms args `thenLne` \ args_fvs ->
- returnLne (StgPrimApp op args live_in_cont, args_fvs, getFVSet args_fvs)
+ returnLne (StgPrim op args live_in_cont, args_fvs, getFVSet args_fvs)
varsExpr (StgSCC ty label expr)
= varsExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
\begin{code}
varsExpr (StgLetNoEscape _ _ _ _) = panic "varsExpr: unexpected StgLetNoEscape"
-varsExpr (StgLet bind body)
+varsExpr (StgLet bind body)
= isSwitchSetLne {-StgDoLetNoEscapes-} `thenLne` \ want_LNEs ->
(fixLne (\ ~(_, _, _, no_binder_escapes) ->
- let
+ let
non_escaping_let = want_LNEs && no_binder_escapes
in
- vars_let non_escaping_let bind body
+ vars_let non_escaping_let bind body
)) `thenLne` \ (new_let, fvs, escs, _) ->
returnLne (new_let, fvs, escs)
\end{code}
-\begin{code}
-#ifdef DPH
--- rest of varsExpr goes here
-
-#endif {- Data Parallel Haskell -}
-\end{code}
-
Applications:
\begin{code}
varsApp :: Maybe UpdateFlag -- Just upd <=> this application is
-- x = [...] \upd [] -> the_app
-- with specified update flag
-> Id -- Function
- -> [PlainStgAtom] -- Arguments
- -> LneM (PlainStgExpr, FreeVarsInfo, EscVarsSet)
+ -> [StgArg] -- Arguments
+ -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
varsApp maybe_thunk_body f args
= getVarsLiveInCont `thenLne` \ live_in_cont ->
varsAtoms args `thenLne` \ args_fvs ->
-
+
lookupVarEnv f `thenLne` \ how_bound ->
-
+
let
- n_args = length args
+ n_args = length args
fun_fvs = singletonFVInfo f how_bound fun_occ
fun_occ =
- case how_bound of
- LetrecBound _ arity _
+ case how_bound of
+ LetrecBound _ arity _
| n_args == 0 -> stgFakeFunAppOcc -- Function Application
-- with no arguments.
-- used by the lambda lifter.
fun_escs = case how_bound of
- LetrecBound _ arity lvs ->
+ LetrecBound _ arity lvs ->
if arity == n_args then
emptyUniqSet -- Function doesn't escape
else
myself -- Inexact application; it does escape
- other -> emptyUniqSet -- Only letrec-bound escapees
+ other -> emptyUniqSet -- Only letrec-bound escapees
-- are interesting
-- At the moment of the call:
other -> emptyUniqSet
in
returnLne (
- StgApp (StgVarAtom f) args live_at_call,
+ StgApp (StgVarArg f) args live_at_call,
fun_fvs `unionFVInfo` args_fvs,
- fun_escs `unionUniqSets` (getFVSet args_fvs)
+ fun_escs `unionUniqSets` (getFVSet args_fvs)
-- All the free vars of the args are disqualified
-- from being let-no-escaped.
)
The magic for lets:
\begin{code}
vars_let :: Bool -- True <=> yes, we are let-no-escaping this let
- -> PlainStgBinding -- bindings
- -> PlainStgExpr -- body
- -> LneM (PlainStgExpr, -- new let
+ -> StgBinding -- bindings
+ -> StgExpr -- body
+ -> LneM (StgExpr, -- new let
FreeVarsInfo, -- variables free in the whole let
EscVarsSet, -- variables that escape from the whole let
Bool) -- True <=> none of the binders in the bindings
-- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
-- together with the live_in_cont ones
lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) `thenLne` \ lvs_from_fvs ->
- let
+ let
bind_lvs = lvs_from_fvs `unionUniqSets` live_in_cont
in
-- but bind_lvs does not
-- Do the body
- extendVarEnv env_ext (
- varsExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
- lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
+ extendVarEnv env_ext (
+ varsExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
+ lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
- returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
- body2, body_fvs, body_escs, body_lvs)
+ returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
+ body2, body_fvs, body_escs, body_lvs)
)) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
body2, body_fvs, body_escs, body_lvs) ->
-- Compute the new let-expression
- let
+ let
new_let = if let_no_escape then
-- trace "StgLetNoEscape!" (
StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
live_in_whole_let
= bind_lvs `unionUniqSets` (body_lvs `minusUniqSet` set_of_binders)
- real_bind_escs = if let_no_escape then
+ real_bind_escs = if let_no_escape then
bind_escs
else
getFVSet bind_fvs
-- this let(rec)
no_binder_escapes = isEmptyUniqSet (set_of_binders `intersectUniqSets` all_escs)
- -- Mustn't depend on the passed-in let_no_escape flag, since
+ -- Mustn't depend on the passed-in let_no_escape flag, since
-- no_binder_escapes is used by the caller to derive the flag!
in
returnLne (
live_vars
)
where
- live_vars = if let_no_escape then
+ live_vars = if let_no_escape then
bind_lvs `unionUniqSets` singletonUniqSet binder
- else
+ else
singletonUniqSet binder
- vars_bind :: PlainStgLiveVars
+ vars_bind :: StgLiveVars
-> FreeVarsInfo -- Free var info for body of binding
- -> PlainStgBinding
- -> LneM (PlainStgBinding,
+ -> StgBinding
+ -> LneM (StgBinding,
FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
[(Id, HowBound)])
-- extension to environment
in
extendVarEnv env_ext (
fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
- let
+ let
rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
in
mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) ->
\begin{code}
type LneM a = Bool -- True <=> do let-no-escapes
-> IdEnv HowBound
- -> PlainStgLiveVars -- vars live in continuation
+ -> StgLiveVars -- vars live in continuation
-> a
type Arity = Int
= ImportBound
| CaseBound
| LambdaBound
- | LetrecBound
+ | LetrecBound
Bool -- True <=> bound at top level
Arity -- Arity
- PlainStgLiveVars -- Live vars... see notes below
+ StgLiveVars -- Live vars... see notes below
\end{code}
-For a let(rec)-bound variable, x, we record what varibles are live if
-x is live. For "normal" variables that is just x alone. If x is
+For a let(rec)-bound variable, x, we record what varibles are live if
+x is live. For "normal" variables that is just x alone. If x is
a let-no-escaped variable then x is represented by a code pointer and
a stack pointer (well, one for each stack). So all of the variables
needed in the execution of x are live if x is, and are therefore recorded
initLne :: Bool -> LneM a -> a
initLne want_LNEs m = m want_LNEs nullIdEnv emptyUniqSet
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenLne #-}
{-# INLINE thenLne_ #-}
{-# INLINE returnLne #-}
-#endif
returnLne :: a -> LneM a
returnLne e sw env lvs_cont = e
Functions specific to this monad:
\begin{code}
-{- NOT USED:
-ifSwitchSetLne :: GlobalSwitch -> LneM a -> LneM a -> LneM a
-ifSwitchSetLne switch then_ else_ switch_checker env lvs_cont
- = (if switch_checker switch then then_ else else_) switch_checker env lvs_cont
--}
-
isSwitchSetLne :: LneM Bool
isSwitchSetLne want_LNEs env lvs_cont
= want_LNEs
-getVarsLiveInCont :: LneM PlainStgLiveVars
+getVarsLiveInCont :: LneM StgLiveVars
getVarsLiveInCont sw env lvs_cont = lvs_cont
-setVarsLiveInCont :: PlainStgLiveVars -> LneM a -> LneM a
+setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
setVarsLiveInCont new_lvs_cont expr sw env lvs_cont
= expr sw env new_lvs_cont
-- only ever tacked onto a decorated expression. It is never used as
-- the basis of a control decision, which might give a black hole.
-lookupLiveVarsForSet :: FreeVarsInfo -> LneM PlainStgLiveVars
+lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
lookupLiveVarsForSet fvs sw env lvs_cont
= returnLne (unionManyUniqSets (map do_one (getFVs fvs)))
%************************************************************************
\begin{code}
-type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
+type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo)
-- If f is mapped to NoStgBinderInfo, that means
-- that f *is* mentioned (else it wouldn't be in the
-- IdEnv at all), but only in a saturated applications.
- --
+ --
-- All case/lambda-bound things are also mapped to
-- NoStgBinderInfo, since we aren't interested in their
-- occurence info.
\end{code}
\begin{code}
-rhsArity :: PlainStgRhs -> Arity
+rhsArity :: StgRhs -> Arity
rhsArity (StgRhsCon _ _ _) = 0
rhsArity (StgRhsClosure _ _ _ _ args _) = length args
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface UpdAnal where
-import Id(Id)
-import StgSyn(StgBinding)
-updateAnalyse :: [StgBinding Id Id] -> [StgBinding Id Id]
-
> module UpdAnal ( updateAnalyse ) where
>
-> IMPORT_Trace
-
-> import AbsUniType ( splitTyArgs, splitType, Class, TyVarTemplate,
+> import Type ( splitTyArgs, splitSigmaTy, Class, TyVarTemplate,
> TauType(..)
> )
> import Id
-> import IdEnv
> import IdInfo
> import Outputable ( isExported )
> import Pretty
> import SrcLoc ( mkUnknownSrcLoc )
> import StgSyn
> import UniqSet
-> import Unique ( getBuiltinUniques )
+> import UniqSupply ( getBuiltinUniques )
> import Util
%-----------------------------------------------------------------------------
repeatedly applied to different environments after that.
> lookup v
-> | isImportedId v
+> | isImportedId v
> = const (case updateInfoMaybe (getIdUpdateInfo v) of
> Nothing -> unknownClosure
> Just spec -> convertUpdateSpec spec)
-> | otherwise
+> | otherwise
> = \p -> case lookup_IdEnv p v of
> Just b -> b
> Nothing -> unknownClosure
udData is used when we are putting a list of closure references into a
data structure, or something else that we know nothing about.
-> udData :: [PlainStgAtom] -> CaseBoundVars -> AbVal
+> udData :: [StgArg] -> CaseBoundVars -> AbVal
> udData vs cvs
> = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom)
-> where local_ids = [ lookup v | (StgVarAtom v) <- vs, v `notCaseBound` cvs ]
+> where local_ids = [ lookup v | (StgVarArg v) <- vs, v `notCaseBound` cvs ]
%-----------------------------------------------------------------------------
\subsection{Analysing an atom}
-> udAtom :: CaseBoundVars -> PlainStgAtom -> AbVal
-> udAtom cvs (StgVarAtom v)
+> udAtom :: CaseBoundVars -> StgArg -> AbVal
+> udAtom cvs (StgVarArg v)
> | v `isCaseBound` cvs = const unknownClosure
> | otherwise = lookup v
>
%-----------------------------------------------------------------------------
\subsection{Analysing an STG expression}
-> ud :: PlainStgExpr -- Expression to be analysed
+> ud :: StgExpr -- Expression to be analysed
> -> CaseBoundVars -- List of case-bound vars
> -> IdEnvClosure -- Current environment
-> -> (PlainStgExpr, AbVal) -- (New expression, abstract value)
+> -> (StgExpr, AbVal) -- (New expression, abstract value)
>
-> ud e@(StgPrimApp _ vs _) cvs p = (e, udData vs cvs)
-> ud e@(StgConApp _ vs _) cvs p = (e, udData vs cvs)
+> ud e@(StgPrim _ vs _) cvs p = (e, udData vs cvs)
+> ud e@(StgCon _ vs _) cvs p = (e, udData vs cvs)
> ud e@(StgSCC ty lab a) cvs p = ud a cvs p =: \(a', abval_a) ->
> (StgSCC ty lab a', abval_a)
> where
> abval_atoms = map (udAtom cvs) atoms
> abval_a = udAtom cvs a
-> abval_app = \p ->
+> abval_app = \p ->
> let doApp :: Closure -> AbVal -> Closure
> doApp (c, b, Fun f) abval_atom =
-> abval_atom p =: \e@(_,_,_) ->
-> f e =: \(c', b', f') ->
+> abval_atom p =: \e@(_,_,_) ->
+> f e =: \(c', b', f') ->
> (combine_IdEnvs (+) c' c, b', f')
> in foldl doApp (abval_a p) abval_atoms
> in
> (StgCase expr' lve lva uniq alts', abval_case)
> where
->
-> udAlt :: PlainStgCaseAlternatives
+>
+> udAlt :: StgCaseAlts
> -> IdEnvClosure
-> -> (PlainStgCaseAlternatives, AbVal)
->
+> -> (StgCaseAlts, AbVal)
+>
> udAlt (StgAlgAlts ty [alt] StgNoDefault) p
> = udAlgAlt p alt =: \(alt', abval) ->
> (StgAlgAlts ty [alt'] StgNoDefault, abval)
> udAlgAlt p (id, vs, use_mask, e)
> = ud e (moreCaseBound cvs vs) p =: \(e', v) -> ((id, vs, use_mask, e'), v)
>
-> udDef :: PlainStgCaseDefault
+> udDef :: StgCaseDefault
> -> IdEnvClosure
-> -> (PlainStgCaseDefault, AbVal)
->
+> -> (StgCaseDefault, AbVal)
+>
> udDef StgNoDefault p
> = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs))
> udDef (StgBindDefault v is_used expr) p
> ud body cvs p =: \(body', abval_body) ->
> abval_body p =: \(c, b, abfun) ->
> tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds ->
-> let
+> let
> abval p
> = abval2 p =: \(c1, p') ->
> abval_body (grow_IdEnv p p') =: \(c2, b, abfun) ->
%-----------------------------------------------------------------------------
\subsection{Analysing bindings}
-
+
For recursive sets of bindings we perform one iteration of a fixed
point algorithm, using (dont_know fv) as a safe approximation to the
real fixed point, where fv are the (mappings in the environment of
We don't need to find anything out about closures with arguments,
constructor closures etc.
-
-> udBinding :: PlainStgBinding
+
+> udBinding :: StgBinding
> -> CaseBoundVars
> -> IdEnvClosure
-> -> (PlainStgBinding,
+> -> (StgBinding,
> [Id],
> IdEnvClosure -> (IdEnvInt, IdEnvClosure),
> IdEnvClosure -> (IdEnvInt, IdEnvClosure))
->
+>
> udBinding (StgNonRec v rhs) cvs p
> = udRhs rhs cvs p =: \(rhs', abval) ->
> abval p =: \(c, b, abfun) ->
> (cs, ps) = unzip (doRec vs abvals)
>
> doRec [] _ = []
-> doRec (v:vs) (abval:as)
+> doRec (v:vs) (abval:as)
> = abval p' =: \(c,b,abfun) ->
> (c, (v,(null_IdEnv, b, abfun))) : doRec vs as
->
+>
> in
> (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps)
->
+>
> udBind (v,rhs)
> = udRhs rhs cvs p =: \(rhs', abval) ->
> (v,(v,rhs'), abval)
>
> collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv
-> collectfv (_, StgRhsCon _ con args) = [ v | (StgVarAtom v) <- args ]
-
+> collectfv (_, StgRhsCon _ con args) = [ v | (StgVarArg v) <- args ]
+
%-----------------------------------------------------------------------------
\subsection{Analysing Right-Hand Sides}
>
> doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal
> doLam i f b p
-> = (null_IdEnv, b,
-> Fun (\x@(c',b',_) ->
+> = (null_IdEnv, b,
+> Fun (\x@(c',b',_) ->
> let b'' = dom_IdEnv c' `merge2` b' `merge2` b in
> f b'' (addOneTo_IdEnv p i x)))
-
+
%-----------------------------------------------------------------------------
\subsection{Adjusting Update flags}
not referenced from inside a data structure or function, and it has no
arguments (closures with arguments are re-entrant).
-> tag :: Refs -> IdEnvInt -> PlainStgBinding -> PlainStgBinding
+> tag :: Refs -> IdEnvInt -> StgBinding -> StgBinding
>
-> tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body))
+> tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body))
> = if (v `notInRefs` b) && (lookupc c v <= 1)
> then -- trace "One!" (
> StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body)
for CAFs (i.e. they could be made non-updateable if only used once,
thus preventing a space leak).
-> updateAnalyse :: PlainStgProgram -> PlainStgProgram {- Exported -}
-> updateAnalyse bs
+> updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -}
+> updateAnalyse bs
> = udProgram bs null_IdEnv
-
-> udProgram :: PlainStgProgram -> IdEnvClosure -> PlainStgProgram
+
+> udProgram :: [StgBinding] -> IdEnvClosure -> [StgBinding]
> udProgram [] p = []
> udProgram (d:ds) p
> = udBinding d noCaseBound p =: \(d', vs, _, abval_bind) ->
>
> mkClosure c b b' [] = (c, b', dont_know b')
> mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns))
-> mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
-> mkClosure
-> (combine_IdEnvs (+) c c')
+> mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
+> mkClosure
+> (combine_IdEnvs (+) c c')
> (dom_IdEnv c' `merge2` b'' `merge2` b)
> (b'' `merge2` b')
> ns ))
> mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) ->
-> mkClosure c
+> mkClosure c
> (dom_IdEnv c' `merge2` b'' `merge2` b)
> (dom_IdEnv c' `merge2` b'' `merge2` b')
> ns ))
> mkUpdateSpec :: Id -> Closure -> UpdateSpec
> mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids)
-> where
+> where
> (c,b,_) = foldl doApp f ids
> ids = map mkid (getBuiltinUniques arity)
> mkid u = mkSysLocal SLIT("upd") u noType mkUnknownSrcLoc
> noType = panic "UpdAnal: no type!"
>
> doApp (c,b,Fun f) i
-> = f (unit_IdEnv i 1, noRefs, dont_know noRefs) =: \(c',b',f') ->
+> = f (unit_IdEnv i 1, noRefs, dont_know noRefs) =: \(c',b',f') ->
> (combine_IdEnvs (+) c' c, b', f')
>
-> (_,dict_tys,tau_ty) = (splitType . getIdUniType) v
+> (_,dict_tys,tau_ty) = (splitSigmaTy . idType) v
> (reg_arg_tys, _) = splitTyArgs tau_ty
> arity = length dict_tys + length reg_arg_tys
> = case b of
> StgNonRec v rhs -> StgNonRec (attachOne v) rhs
> StgRec bs -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ]
->
+>
> where attachOne v
-> | isExported v
+> | isExported v
> = let c = lookup v p in
-> addIdUpdateInfo v
+> addIdUpdateInfo v
> (mkUpdateInfo (mkUpdateSpec v c))
> | otherwise = v
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+%
+\section[SpecEnv]{Specialisation info about an @Id@}
+
+\begin{code}
+#include "HsVersions.h"
+
+module SpecEnv (
+ SpecEnv(..), MatchEnv,
+ nullSpecEnv, isNullSpecEnv,
+ addOneToSpecEnv, lookupSpecEnv,
+ specEnvToList
+ ) where
+
+import Ubiq
+
+import MatchEnv
+import Type ( matchTys, isTyVarTy )
+import Usage ( UVar(..) )
+\end{code}
+
+
+A @SpecEnv@ holds details of an @Id@'s specialisations:
+
+\begin{code}
+type CoreExpr = GenCoreExpr Id Id TyVar Unique
+type SpecEnv = MatchEnv [Type] CoreExpr
+\end{code}
+
+For example, if \tr{f}'s @SpecEnv@ contains the mapping:
+\begin{verbatim}
+ [List a, b] ===> (\d -> f' a b)
+\end{verbatim}
+then
+\begin{verbatim}
+ f (List Int) Bool d ===> f' Int Bool
+\end{verbatim}
+
+\begin{code}
+nullSpecEnv :: SpecEnv
+nullSpecEnv = nullMEnv
+
+isNullSpecEnv :: SpecEnv -> Bool
+isNullSpecEnv env = null (mEnvToList env)
+
+specEnvToList :: SpecEnv -> [([Type],CoreExpr)]
+specEnvToList env = mEnvToList env
+
+addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], CoreExpr)
+addOneToSpecEnv env tys rhs = insertMEnv matchTys env tys rhs
+
+lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (CoreExpr, [(TyVar,Type)])
+lookupSpecEnv env tys
+ | all isTyVarTy tys = Nothing -- Short cut: no specialisation for simple tyvars
+ | otherwise = lookupMEnv matchTys env tys
+\end{code}
+
+
+
+=================================================================
+ BELOW HERE SCHEDULED FOR DELETION!
+
+
+The details of one specialisation, held in an @Id@'s
+@SpecEnv@ are as follows:
+\begin{pseudocode}
+data SpecInfo
+ = SpecInfo [Maybe Type] -- Instance types; no free type variables in here
+ Int -- No. of dictionaries to eat
+ Id -- Specialised version
+\end{pseudocode}
+
+For example, if \tr{f} has this @SpecInfo@:
+\begin{verbatim}
+ SpecInfo [Just t1, Nothing, Just t3] 2 f'
+\end{verbatim}
+then
+\begin{verbatim}
+ f t1 t2 t3 d1 d2 ===> f t2
+\end{verbatim}
+The \tr{Nothings} identify type arguments in which the specialised
+version is polymorphic.
+
+\begin{pseudocode}
+data SpecEnv = SpecEnv [SpecInfo]
+
+mkSpecEnv = SpecEnv
+nullSpecEnv = SpecEnv []
+addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
+
+
+lookupConstMethodId :: Id -> Type -> Maybe Id
+ -- slight variant on "lookupSpecEnv" below
+
+lookupConstMethodId sel_id spec_ty
+ = case (getInfo (getIdInfo sel_id)) of
+ SpecEnv spec_infos -> firstJust (map try spec_infos)
+ where
+ try (SpecInfo (Just ty:nothings) _ const_meth_id)
+ = ASSERT(all nothing_is_nothing nothings)
+ case (cmpType True{-properly-} ty spec_ty) of
+ EQ_ -> Just const_meth_id
+ _ -> Nothing
+
+ nothing_is_nothing Nothing = True -- debugging only
+ nothing_is_nothing _ = panic "nothing_is_nothing!"
+
+lookupSpecId :: Id -- *un*specialised Id
+ -> [Maybe Type] -- types to which it is to be specialised
+ -> Id -- specialised Id
+
+lookupSpecId unspec_id ty_maybes
+ = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos ->
+
+ case (firstJust (map try spec_infos)) of
+ Just id -> id
+ Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id)))
+ }
+ where
+ try (SpecInfo template_maybes _ id)
+ | and (zipWith same template_maybes ty_maybes)
+ && length template_maybes == length ty_maybes = Just id
+ | otherwise = Nothing
+
+ same Nothing Nothing = True
+ same (Just ty1) (Just ty2) = ty1 == ty2
+ same _ _ = False
+
+lookupSpecEnv :: SpecEnv
+ -> [Type]
+ -> Maybe (Id,
+ [Type],
+ Int)
+
+lookupSpecEnv (SpecEnv []) _ = Nothing -- rather common case
+
+lookupSpecEnv spec_env [] = Nothing -- another common case
+
+ -- This can happen even if there is a non-empty spec_env, because
+ -- of eta reduction. For example, we might have a defn
+ --
+ -- f = /\a -> \d -> g a d
+ -- which gets transformed to
+ -- f = g
+ --
+ -- Now g isn't applied to any arguments
+
+lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
+ = select_match spec_infos
+ where
+ select_match [] -- no matching spec_infos
+ = Nothing
+ select_match (SpecInfo ty_maybes toss spec_id : rest)
+ = case (match ty_maybes spec_tys) of
+ Nothing -> select_match rest
+ Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
+
+ -- Ambiguity can only arise as a result of specialisations with
+ -- an explicit spec_id. The best match is deemed to be the match
+ -- with least polymorphism i.e. has the least number of tys left.
+ -- This is a non-critical approximation. The only type arguments
+ -- where there may be some discretion is for non-overloaded boxed
+ -- types. Unboxed types must be matched and we insist that we
+ -- always specialise on overloaded types (and discard all the dicts).
+
+ select_next best _ toss []
+ = case best of
+ [match] -> Just match -- Unique best match
+ ambig -> pprPanic "Ambiguous Specialisation:\n"
+ (ppAboves [ppStr "(check specialisations with explicit spec ids)",
+ ppCat (ppStr "between spec ids:" :
+ map (ppr PprDebug) [id | (id, _, _) <- ambig]),
+ pp_stuff])
+
+ select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
+ = ASSERT(dnum == toss)
+ case (match ty_maybes spec_tys) of
+ Nothing -> select_next best tnum dnum rest
+ Just tys_left ->
+ let tys_len = length tys_left in
+ case _tagCmp tnum tys_len of
+ _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest -- better match
+ _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match
+ _GT -> select_next best tnum dnum rest -- worse match
+
+
+ match [{-out of templates-}] [] = Just []
+
+ match (Nothing:ty_maybes) (spec_ty:spec_tys)
+ = case (isUnboxedDataType spec_ty) of
+ True -> Nothing -- Can only match boxed type against
+ -- type argument which has not been
+ -- specialised on
+ False -> case match ty_maybes spec_tys of
+ Nothing -> Nothing
+ Just tys -> Just (spec_ty:tys)
+
+ match (Just ty:ty_maybes) (spec_ty:spec_tys)
+ = case (cmpType True{-properly-} ty spec_ty) of
+ EQ_ -> match ty_maybes spec_tys
+ other -> Nothing
+
+ match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
+ -- This is a Real Problem
+
+ match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
+ -- Partial eta abstraction might make this happen;
+ -- meanwhile let's leave in the check
+
+ pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
+\end{pseudocode}
+
+
+\begin{pseudocode}
+instance OptIdInfo SpecEnv where
+ noInfo = nullSpecEnv
+
+ getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
+
+ addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
+ = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
+ -- We *add* the new specialisation info rather than just replacing it
+ -- so that we don't lose old specialisation details.
+
+ ppInfo sty better_id_fn spec_env
+ = pp_specs sty True better_id_fn nullIdEnv spec_env
+
+pp_specs sty _ _ _ (SpecEnv []) = pp_NONE
+pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
+ = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
+ ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
+ ppInt numds,
+ let
+ better_spec_id = better_id_fn spec_id
+ spec_id_info = getIdInfo better_spec_id
+ in
+ if not print_spec_ids || boringIdInfo spec_id_info then
+ ppNil
+ else
+ ppCat [ppChar '{',
+ ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
+ ppChar '}']
+ ]
+ | (SpecInfo ty_maybes numds spec_id) <- specs ])
+ where
+ pp_the_list [p] = p
+ pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
+
+ pp_maybe Nothing = ifPprInterface sty pp_NONE
+ pp_maybe (Just t) = pprParendType sty t
+\end{pseudocode}
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SpecTyFuns where
-import Bag(Bag)
-import Class(Class)
-import Id(Id)
-import Maybes(Labda(..))
-import PreludePS(_PackedString)
-import Pretty(Pretty(..), PrettyRep)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-type ConstraintVector = [Bool]
-data Labda a = Hamna | Ni a
-type Pretty = Int -> Bool -> PrettyRep
-data UniType
-argTysMatchSpecTys_error :: [Labda UniType] -> [UniType] -> Labda (Int -> Bool -> PrettyRep)
-getIdOverloading :: Id -> ([TyVarTemplate], [(Class, TyVarTemplate)])
-isUnboxedSpecialisation :: [Labda UniType] -> Bool
-mkConstraintVector :: Id -> [Bool]
-mkSpecialisedCon :: Id -> [UniType] -> Id
-pprSpecErrs :: _PackedString -> Bag (Id, [Labda UniType]) -> Bag (Id, [Labda UniType]) -> Bag (TyCon, [Labda UniType]) -> Int -> Bool -> PrettyRep
-specialiseCallTys :: Bool -> Bool -> Bool -> [Bool] -> [UniType] -> [Labda UniType]
-specialiseConstrTys :: [UniType] -> [Labda UniType]
-
\begin{code}
#include "HsVersions.h"
-module SpecTyFuns (
+module SpecUtils (
specialiseCallTys,
ConstraintVector(..),
getIdOverloading,
argTysMatchSpecTys_error,
- pprSpecErrs,
-
- Maybe(..), Pretty(..), UniType
+ pprSpecErrs
) where
-import AbsUniType
+import Type
import Bag ( Bag, isEmptyBag, bagToList )
import FiniteMap ( FiniteMap, emptyFM, addListToFM_C,
plusFM_C, keysFM, lookupWithDefaultFM
)
-import Id ( mkSameSpecCon, getIdUniType,
+import Id ( mkSameSpecCon, idType,
isDictFunId, isConstMethodId_maybe,
isDefaultMethodId_maybe,
getInstIdModule, Id )
-import Maybes
+import Maybes
import Outputable
import Pretty
import Util
-> Bool -- Specialise on unboxed type args
-> Bool -- Specialise on overloaded type args
-> ConstraintVector -- Tells which type args are overloaded
- -> [UniType] -- Type args
- -> [Maybe UniType] -- Nothings replace non-specialised type args
+ -> [Type] -- Type args
+ -> [Maybe Type] -- Nothings replace non-specialised type args
specialiseCallTys True _ _ cvec tys
= map Just tys
specialiseCallTys False spec_unboxed spec_overloading cvec tys
- = zipWith spec_ty_other cvec tys
+ = zipWithEqual spec_ty_other cvec tys
where
spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty)
- || (spec_overloading && c)
- = Just ty
+ || (spec_overloading && c)
+ = Just ty
| otherwise
- = Nothing
+ = Nothing
\end{code}
-@getIdOverloading@ grabs the type of an Id, and returns a
+@getIdOverloading@ grabs the type of an Id, and returns a
list of its polymorphic variables, and the initial segment of
its ThetaType, in which the classes constrain only type variables.
For example, if the Id's type is
This seems curious at first. For a start, the type above looks odd,
because we usually only have dictionary args whose types are of
the form (C a) where a is a type variable. But this doesn't hold for
-the functions arising from instance decls, which sometimes get
+the functions arising from instance decls, which sometimes get
arguements with types of form (C (T a)) for some type constructor T.
Should we specialise wrt this compound-type dictionary? This is
getIdOverloading id
= (tyvars, tyvar_part_of theta)
where
- (tyvars, theta, _) = splitType (getIdUniType id)
+ (tyvars, theta, _) = splitSigmaTy (idType id)
tyvar_part_of [] = []
tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
\begin{code}
type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise
-mkConstraintVector :: Id
- -> ConstraintVector
+mkConstraintVector :: Id
+ -> ConstraintVector
mkConstraintVector id
= [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
\end{code}
\begin{code}
-isUnboxedSpecialisation :: [Maybe UniType] -> Bool
+isUnboxedSpecialisation :: [Maybe Type] -> Bool
isUnboxedSpecialisation tys
= any is_unboxed tys
where
specialised on. We only speciailise on unboxed types.
\begin{code}
-specialiseConstrTys :: [UniType]
- -> [Maybe UniType]
+specialiseConstrTys :: [Type]
+ -> [Maybe Type]
specialiseConstrTys tys
= map maybe_unboxed_ty tys
\end{code}
\begin{code}
-mkSpecialisedCon :: Id -> [UniType] -> Id
+mkSpecialisedCon :: Id -> [Type] -> Id
mkSpecialisedCon con tys
= if spec_reqd
then mkSameSpecCon spec_tys con
@argTysMatchSpecTys@ checks if a list of argument types is consistent
with a list of specialising types. An error message is returned if not.
\begin{code}
-argTysMatchSpecTys_error :: [Maybe UniType]
- -> [UniType]
+argTysMatchSpecTys_error :: [Maybe Type]
+ -> [Type]
-> Maybe Pretty
argTysMatchSpecTys_error spec_tys arg_tys
= if match spec_tys arg_tys
then Nothing
else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
- ppStr "argtys=", ppSep [pprParendUniType PprDebug ty | ty <- arg_tys]])
+ ppStr "argtys=", ppSep [pprParendType PprDebug ty | ty <- arg_tys]])
where
match (Nothing:spec_tys) (arg:arg_tys)
= not (isUnboxedDataType arg) &&
- match spec_tys arg_tys
+ match spec_tys arg_tys
match (Just spec:spec_tys) (arg:arg_tys)
= case (cmpUniType True{-properly-} spec arg) of
- EQ_ -> match spec_tys arg_tys
- other -> False
+ EQ_ -> match spec_tys arg_tys
+ other -> False
match [] [] = True
match _ _ = False
\end{code}
\begin{code}
pprSpecErrs :: FAST_STRING -- module name
- -> (Bag (Id,[Maybe UniType])) -- errors
- -> (Bag (Id,[Maybe UniType])) -- warnings
- -> (Bag (TyCon,[Maybe UniType])) -- errors
+ -> (Bag (Id,[Maybe Type])) -- errors
+ -> (Bag (Id,[Maybe Type])) -- warnings
+ -> (Bag (TyCon,[Maybe Type])) -- errors
-> Pretty
pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
= ppAboves [
ppStr "SPECIALISATION MESSAGES:",
ppAboves (map pp_module_specs use_modules)
- ]
+ ]
where
any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
any_warn = not (isEmptyBag spec_warn)
mk_module_fm get_mod_data errs_bag
= addListToFM_C (++) emptyFM errs_list
where
- errs_list = map get_mod_data (bagToList errs_bag)
+ errs_list = map get_mod_data (bagToList errs_bag)
tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
from_prelude mod
= SLIT("Prelude") == (_SUBSTR_ mod 0 6)
-
+
module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
mods = map head (equivClasses _CMP_STRING_ module_names)
else case _CMP_STRING_ (head mods) _NIL_ of
EQ_ -> ([_NIL_], tail mods)
other -> ([], mods)
-
+
(prels, others) = partition from_prelude known
use_modules = unks ++ prels ++ others
= ppNil
where
- mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
- mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
+ mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
+ mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
have_specs = not (null mod_tyspecs && null mod_idspecs)
- ty_sty = PprInterface (error "SpecTyFuns:PprInterface:sw_chkr")
+ ty_sty = PprInterface (error "SpecUtils:PprInterface:sw_chkr")
pp_module mod
= ppBesides [ppPStr mod, ppStr ":"]
-pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe UniType]) -> Pretty
+pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
pp_tyspec sty pp_mod (_, tycon, tys)
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE", ppStr "data",
- pprNonOp PprForUser tycon, ppCat (map (pprParendUniType sty) spec_tys),
+ pprNonOp PprForUser tycon, ppCat (map (pprParendType sty) spec_tys),
ppStr "#-}", ppStr "{- Essential -}"
- ]
+ ]
where
tvs = getTyConTyVarTemplates tycon
(spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv)
choose_ty (tv, Just ty) = (ty, Nothing)
-pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe UniType], Bool) -> Pretty
+pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
pp_idspec sty pp_mod (_, id, tys, is_err)
| isDictFunId id
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
ppStr "instance",
- pprUniType sty spec_ty,
+ pprType sty spec_ty,
ppStr "#-}", pp_essential ]
| is_const_method_id
ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
pp_clsop clsop_str, ppStr "::",
- pprUniType sty spec_ty,
+ pprType sty spec_ty,
ppStr "#-} {- IN instance",
- ppPStr cls_str, pprParendUniType sty clsty,
+ ppPStr cls_str, pprParendType sty clsty,
ppStr "-}", pp_essential ]
| is_default_method_id
ppPStr cls_str,
ppStr "EXPLICIT METHOD REQUIRED",
pp_clsop clsop_str, ppStr "::",
- pprUniType sty spec_ty,
+ pprType sty spec_ty,
ppStr "-}", pp_essential ]
| otherwise
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
pprNonOp PprForUser id, ppStr "::",
- pprUniType sty spec_ty,
+ pprType sty spec_ty,
ppStr "#-}", pp_essential ]
where
- spec_ty = specialiseTy (getIdUniType id) tys 100 -- HACK to drop all dicts!!!
+ spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
const_method_maybe = isConstMethodId_maybe id
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Specialise where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import FiniteMap(FiniteMap)
-import Id(Id)
-import Maybes(Labda)
-import SplitUniq(SplitUniqSupply)
-import TyCon(TyCon)
-import UniType(UniType)
-data Bag a
-data FiniteMap a b
-data SpecialiseData = SpecData Bool Bool [TyCon] [TyCon] (FiniteMap TyCon [(Bool, [Labda UniType])]) (Bag (Id, [Labda UniType])) (Bag (Id, [Labda UniType])) (Bag (TyCon, [Labda UniType]))
-initSpecData :: [TyCon] -> FiniteMap TyCon [(Bool, [Labda UniType])] -> SpecialiseData
-specProgram :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> SpecialiseData -> ([CoreBinding Id Id], SpecialiseData)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
) where
-import PlainCore
-import SpecTyFuns
+import SpecUtils
-IMPORT_Trace
-import Outputable -- ToDo: these may be removable...
-import Pretty
-
-import AbsPrel ( liftDataCon, PrimOp(..), PrimKind -- for CCallOp
+import PrelInfo ( liftDataCon, PrimOp(..), PrimRep -- for CCallOp
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType
+import Type
import Bag
import CmdLineOpts ( GlobalSwitch(..) )
import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
import FiniteMap
import Id
-import IdEnv
import IdInfo -- All of it
-import InstEnv ( lookupClassInstAtSimpleType )
import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) )
-import TyVarEnv -- ( growTyVarEnvList, nullTyVarEnv, TyVarEnv, TypeEnv(..) )
import UniqSet -- All of it
import Util
-import SplitUniq
+import UniqSupply
infixr 9 `thenSM`
\end{code}
let f = <f_rhs>
in <body>
-and suppose f is overloaded.
+and suppose f is overloaded.
STEP 1: CALL-INSTANCE COLLECTION
partial applications.)
There's a choice of whether to collect details of all *polymorphic* functions
-or simply all *overloaded* ones. How to sort this out?
+or simply all *overloaded* ones. How to sort this out?
Pass in a predicate on the function to say if it is "interesting"?
This is dependent on the user flags: SpecialiseOverloaded
SpecialiseUnboxed
- SpecialiseAll
+ SpecialiseAll
STEP 2: EQUIVALENCES
Recursion
~~~~~~~~~
-Wait a minute! What if f is recursive? Then we can't just plug in
+Wait a minute! What if f is recursive? Then we can't just plug in
its right-hand side, can we?
But it's ok. The type checker *always* creates non-recursive definitions
becomes
- f a (d::Num a) = let p = +.sel a d
+ f a (d::Num a) = let p = +.sel a d
in
letrec fl (y::a) = fl (p y y)
- in
+ in
fl
We still have recusion for non-overloadd functions which we
After typechecking we have
g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
- in +.sel a d (f a d y) (f a d y)
+ in +.sel a d (f a d y) (f a d y)
Notice that the call to f is at type type "a"; a non-constant type.
Both calls to f are at the same type, so we can specialise to give:
g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
- in +.sel a d (f@a y) (f@a y)
+ in +.sel a d (f@a y) (f@a y)
(b) The other case is when the type variables in the instance types
are *not* in scope at the definition point of f. The example we are
working with above is a good case. There are two instances of (+.sel a d),
-but "a" is not in scope at the definition of +.sel. Can we do anything?
+but "a" is not in scope at the definition of +.sel. Can we do anything?
Yes, we can "common them up", a sort of limited common sub-expression deal.
This would give:
g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
f@a (x::a) = +.sel@a x x
- in +.sel@a (f@a y) (f@a y)
+ in +.sel@a (f@a y) (f@a y)
This can save work, and can't be spotted by the type checker, because
the two instances of +.sel weren't originally at the same type.
* Don't bother unless the equivalence class has more than one item!
-Not clear whether this is all worth it. It is of course OK to
+Not clear whether this is all worth it. It is of course OK to
simply discard call-instances when passing a big lambda.
Polymorphism 2 -- Overloading
That suggests that we should identify which of g's type variables
are constrained (like "a") and which are unconstrained (like "b").
-Then when taking equivalence classes in STEP 2, we ignore the type args
+Then when taking equivalence classes in STEP 2, we ignore the type args
corresponding to unconstrained type variable. In STEP 3 we make
polymorphic versions. Thus:
f df x = let g :: Eq a => a -> a -> Bool
g dg p q = == dg p q
h :: Num a => a -> a -> (a, Bool)
- h dh r s = let deq = eqFromNum dh
+ h dh r s = let deq = eqFromNum dh
in (+ dh r s, g deq r s)
in
h df x x
After specialising h we get a specialised version of h, like this:
- h' r s = let deq = eqFromNum df
+ h' r s = let deq = eqFromNum df
in (+ df r s, g deq r s)
But we can't naively make an instance for g from this, because deq is not in scope
-at the defn of g. Instead, we have to float out the (new) defn of deq
+at the defn of g. Instead, we have to float out the (new) defn of deq
to widen its scope. Notice that this floating can't be done in advance -- it only
shows up when specialisation is done.
Indeed the pragmas *have* to be dealt with by the type checker, because
only it knows how to build the dictionaries d1 and d2! For example
- g :: Ord a => [a] -> [a]
+ g :: Ord a => [a] -> [a]
{-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
Here, the specialised version of g is an application of g's rhs to the
We *insist* that all overloaded type variables are specialised to ground types,
(and hence there can be no context inside a SPECIALIZE pragma).
-We *permit* unconstrained type variables to be specialised to
+We *permit* unconstrained type variables to be specialised to
- a ground type
- or left as a polymorphic type variable
but nothing in between. So
{-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
-
+
is *illegal*. (It can be handled, but it adds complication, and gains the
programmer nothing.)
When we make one of these specialised instances, we are defining
a constant dictionary, and so we want immediate access to its constant
methods and superclasses. Indeed, these constant methods and superclasses
-must be in the IdInfo for the class selectors! We need help from the
+must be in the IdInfo for the class selectors! We need help from the
typechecker to sort this out, perhaps by generating a separate IdInfo
for each.
Lastly, there's no such thing as a local instance decl, so we can
survive solely by spitting out *usage* information, and then reading that
-back in as a pragma when next compiling the file. So for now,
+back in as a pragma when next compiling the file. So for now,
we only specialise instance decls in response to pragmas.
-That means that even if an instance decl ain't otherwise exported it
+That means that even if an instance decl ain't otherwise exported it
needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
something to say which module defined the instance, so the usage info
can be fed into the right reqts info file. Blegh.
In addition to normal call instances we gather TyCon call instances at
unboxed types, determine equivalence classes for the locally defined
TyCons and build speciailised data constructor Ids for each TyCon and
-substitute these in the CoCon calls.
+substitute these in the Con calls.
We need the list of local TyCons to partition the TyCon instance info.
We pass out a FiniteMap from local TyCons to Specialised Instances to
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SpecInfo
- [Maybe UniType] -- Instance types
+ [Maybe Type] -- Instance types
Int -- No of dicts to eat
Id -- Specialised version
-For example, if f has this SpecInfo:
+For example, if f has this SpecInfo:
SpecInfo [Just t1, Nothing, Just t3] 2 f'
==.sel [t] d
-we can't transform to
+we can't transform to
eqList (==.sel t d')
-where
+where
eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
Of course, we currently have no way to automatically derive
~~~~~~~~~~~~~
What about types/classes mentioned in SPECIALIZE pragmas spat out,
but not otherwise exported. Even if they are exported, what about
-their original names.
+their original names.
Suggestion: use qualified names in pragmas, omitting module for
prelude and "this module".
map_*_* f (x:xs) = let h = f x
t = map f xs
- in h:t
+ in h:t
Could convert let to case:
map_*_Int# f (x:xs) = case f x of h# ->
- let t = map f xs
- in h#:t
+ let t = map f xs
+ in h#:t
This may be undesirable since it forces evaluation here, but the value
may not be used in all branches of the body. In the general case this
is used:
map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
- t = map f xs
- in case h of
+ t = map f xs
+ in case h of
_Lift h# -> h#:t
Now give it to the simplifier and the _Lifting will be optimised away.
filtermap_*_* p f (x:xs)
= let h = f x
t = ...
- in case p x of
+ in case p x of
True -> h:t
False -> t
==>
filtermap_*_Int# p f (x:xs)
= let h = case (f x) of h# -> _Lift h#
t = ...
- in case p x of
+ in case p x of
True -> case h of _Lift h#
-> h#:t
False -> t
type FreeVarsSet = UniqSet Id
type FreeTyVarsSet = UniqSet TyVar
-data CallInstance
- = CallInstance
+data CallInstance
+ = CallInstance
Id -- This Id; *new* ie *cloned* id
- [Maybe UniType] -- Specialised at these types (*new*, cloned)
+ [Maybe Type] -- Specialised at these types (*new*, cloned)
-- Nothing => no specialisation on this type arg
-- is required (flag dependent).
- [PlainCoreArg] -- And these dictionaries; all ValArgs
+ [CoreArg] -- And these dictionaries; all ValArgs
FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
(Maybe SpecInfo) -- For specialisation with explicit SpecId
\end{code}
4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
case maybe_specinfo of
Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts])
- Just (SpecInfo _ _ spec_id)
+ Just (SpecInfo _ _ spec_id)
-> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
])
\begin{code}
cmpCI :: CallInstance -> CallInstance -> TAG_
-cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
- = case cmpId id1 id2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
+cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
+ = case (id1 `cmp` id2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
cmpCI_tys :: CallInstance -> CallInstance -> TAG_
cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
= any (eqId ci_id) ids
-singleCI :: Id -> [Maybe UniType] -> [PlainCoreArg] -> UsageDetails
+singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
singleCI id tys dicts
= UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
emptyBag [] emptyUniqSet 0 0
where
- fv_set = mkUniqSet (id : [dict | ValArg (CoVarAtom dict) <- dicts])
+ fv_set = mkUniqSet (id : [dict | ValArg (VarArg dict) <- dicts])
-explicitCI :: Id -> [Maybe UniType] -> SpecInfo -> UsageDetails
+explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
explicitCI id tys specinfo
= UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet 0 0
where
getCIids _ ids = ids
not_dict_or_defm id
- = not (isDictTy (getIdUniType id) || maybeToBool (isDefaultMethodId_maybe id))
+ = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
dumpCIs :: Bag CallInstance -- The call instances
-> Bool -- True <=> top level bound Ids
-> Bool -- True <=> dict bindings to be floated (specBind only)
- -> [CallInstance] -- Call insts for bound ids (instBind only)
+ -> [CallInstance] -- Call insts for bound ids (instBind only)
-> [Id] -- Bound ids *new*
-> [Id] -- Full bound ids: includes dumped dicts
-> Bag CallInstance -- Kept call instances
- -- CIs are dumped if:
+ -- CIs are dumped if:
-- 1) they are a CI for one of the bound ids, or
-- 2) they mention any of the dicts in a local unfloated binding
--
-- For top-level bindings we allow the call instances to
-- float past a dict bind and place all the top-level binds
- -- in a *global* CoRec.
+ -- in a *global* Rec.
-- We leave it to the simplifier will sort it all out ...
dumpCIs cis top_lev floating inst_cis bound_ids full_ids
not (isEmptyBag cis_of_bound_id_without_inst_cis)
then
pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
- " (may be a non-HM recursive call)\n")
+ " (may be a non-HM recursive call)\n")
(ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"])
- 4 (ppAboves [ppStr "Dumping CIs:",
+ 4 (ppAboves [ppStr "Dumping CIs:",
ppAboves (map pprCI (bagToList cis_of_bound_id)),
ppStr "Instantiating CIs:",
ppAboves (map pprCI inst_cis)]))
else
(if not (isEmptyBag cis_dump_unboxed)
then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
- (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"])
+ (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"])
4 (ppAboves (map pprCI (bagToList cis_dump))))
else id)
cis_keep_not_bound_id
(cis_dump, cis_keep_not_bound_id)
= partitionBag ok_to_dump_ci cis_not_bound_id
- ok_to_dump_ci (CallInstance _ _ _ fv_set _)
+ ok_to_dump_ci (CallInstance _ _ _ fv_set _)
= or [i `elementOfUniqSet` fv_set | i <- full_ids]
(_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
Here, the type, t, at which f is used in its own RHS should be
just "a"; that is, the recursive call is at the same type as
the original call. That means that when specialising f at some
-type, say Int#, we shouldn't find any *new* instances of f
+type, say Int#, we shouldn't find any *new* instances of f
arising from specialising f's RHS. The only instance we'll find
is another call of (f Int#).
\begin{code}
data TyConInstance
= TyConInstance TyCon -- Type Constructor
- [Maybe UniType] -- Applied to these specialising types
+ [Maybe Type] -- Applied to these specialising types
cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
-cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
- = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
+cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
+ = case (cmp tc1 tc2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
-cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
+cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
= cmpUniTypeMaybeList tys1 tys2
-singleTyConI :: TyCon -> [Maybe UniType] -> UsageDetails
-singleTyConI ty_con spec_tys
+singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
+singleTyConI ty_con spec_tys
= UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet 0 0
isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
\begin{code}
data UsageDetails
- = UsageDetails
+ = UsageDetails
(Bag CallInstance) -- The collection of call-instances
(Bag TyConInstance) -- Constructor call-instances
[DictBindDetails] -- Dictionary bindings in data-dependence order!
A @DictBindDetails@ contains bindings for dictionaries *only*.
\begin{code}
-data DictBindDetails
- = DictBindDetails
+data DictBindDetails
+ = DictBindDetails
[Id] -- Main binders, originally visible in scope of binding (cloned)
- PlainCoreBinding -- Fully processed
+ CoreBinding -- Fully processed
FreeVarsSet -- Free in binding group (cloned)
FreeTyVarsSet -- Free in binding group
\end{code}
emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet 0 0
-unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
+unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
= UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
- (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) (c1+c2) (i1+i2)
+ (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) (c1+c2) (i1+i2)
-- The append here is really redundant, since the bindings don't
-- scope over each other. ToDo.
unionUDList = foldr unionUDs emptyUDs
-singleFvUDs (CoVarAtom v) | not (isImportedId v)
+singleFvUDs (VarArg v) | not (isImportedId v)
= UsageDetails emptyBag emptyBag [] (singletonUniqSet v) 0 0
singleFvUDs other
= emptyUDs
singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con) 0 0
-dumpDBs :: [DictBindDetails]
+dumpDBs :: [DictBindDetails]
-> Bool -- True <=> top level bound Ids
-> [TyVar] -- TyVars being bound (cloned)
-> [Id] -- Ids being bound (cloned)
-> FreeVarsSet -- Fvs of body
- -> ([PlainCoreBinding], -- These ones have to go here
+ -> ([CoreBinding], -- These ones have to go here
[DictBindDetails], -- These can float further
[Id], -- Incoming list + names of dicts bound here
FreeVarsSet -- Incoming fvs + fvs of dicts bound here
-- auxillary derived instance defns and user instance
-- defns all getting in the way.
-- So we dump all dbinds as soon as we get to the top
- -- level and place them in a *global* CoRec.
+ -- level and place them in a *global* Rec.
-- We leave it to the simplifier will sort it all out ...
dumpDBs [] top_lev bound_tyvars bound_ids fvs
= ([], [], bound_ids, fvs)
-dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
+dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
top_lev bound_tyvars bound_ids fvs
| top_lev
|| or [i `elementOfUniqSet` db_fvs | i <- bound_ids]
(dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
-
+
dumpUDs :: UsageDetails
-> Bool -- True <=> top level bound Ids
-> Bool -- True <=> dict bindings to be floated (specBind only)
-> [CallInstance] -- Call insts for bound Ids (instBind only)
-> [Id] -- Ids which are just being bound; *new*
-> [TyVar] -- TyVars which are just being bound
- -> ([PlainCoreBinding], -- Bindings from UsageDetails which mention the ids
+ -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids
UsageDetails) -- The above bindings removed, and
-- any call-instances which mention the ids dumped too
\end{code}
\begin{code}
-addDictBinds :: [Id] -> PlainCoreBinding -> UsageDetails -- Dict binding and RHS usage
+addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage
-> UsageDetails -- The usage to augment
-> UsageDetails
addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
(UsageDetails cis tycon_cis dbs fvs c i)
= UsageDetails (db_cis `unionBags` cis)
(db_tycon_cis `unionBags` tycon_cis)
- (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
+ (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
fvs c i
-- NB: We ignore counts from dictbinds since it is not user code
where
-- The free tyvars of the dictionary bindings should really be
-- gotten from the RHSs, but I'm pretty sure it's good enough just
- -- to look at the type of the dictionary itself.
+ -- to look at the type of the dictionary itself.
-- Doing the proper job would entail keeping track of free tyvars as
-- well as free vars, which would be a bore.
- db_ftvs = mkUniqSet (extractTyVarsFromTys (map getIdUniType dbinders))
+ db_ftvs = mkUniqSet (extractTyVarsFromTys (map idType dbinders))
\end{code}
%************************************************************************
@SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
-1) (NoLift CoLitAtom l) : an Id which is bound to a literal
+1) (NoLift LitArg l) : an Id which is bound to a literal
-2) (NoLift CoLitAtom l) : an Id bound to a "new" Id
+2) (NoLift LitArg l) : an Id bound to a "new" Id
The new Id is a possibly-type-specialised clone of the original
3) Lifted lifted_id unlifted_id :
type SpecIdEnv = IdEnv CloneInfo
data CloneInfo
- = NoLift PlainCoreAtom -- refers to cloned id or literal
+ = NoLift CoreArg -- refers to cloned id or literal
| Lifted Id -- lifted, cloned id
Id -- unlifted, cloned id
[TyCon]
-- Those in-scope data types for which we want to
-- generate code for their constructors.
- -- Namely: data types declared in this module +
+ -- Namely: data types declared in this module +
-- any big tuples used in this module
-- The initial (and default) value is the local tycons
- (FiniteMap TyCon [(Bool, [Maybe UniType])])
+ (FiniteMap TyCon [(Bool, [Maybe Type])])
-- TyCon specialisations to be generated
-- We generate specialialised code (Bool=True) for data types
-- defined in this module and any tuples used in this module
-- requested by source-level SPECIALIZE data pragmas (Bool=True)
-- and _SPECIALISE_ pragmas (Bool=False) in the interface files
- (Bag (Id,[Maybe UniType]))
+ (Bag (Id,[Maybe Type]))
-- Imported specialisation errors
- (Bag (Id,[Maybe UniType]))
+ (Bag (Id,[Maybe Type]))
-- Imported specialisation warnings
- (Bag (TyCon,[Maybe UniType]))
+ (Bag (TyCon,[Maybe Type]))
-- Imported TyCon specialisation errors
initSpecData local_tycons tycon_specs
\begin{code}
specProgram :: (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> [PlainCoreBinding] -- input ...
+ -> UniqSupply
+ -> [CoreBinding] -- input ...
-> SpecialiseData
- -> ([PlainCoreBinding], -- main result
+ -> ([CoreBinding], -- main result
SpecialiseData) -- result specialise data
specProgram sw_chker uniqs binds
(SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
= case (initSM (specTyConsAndScope (specTopBinds binds)) sw_chker uniqs) of
- (final_binds, tycon_specs_list,
+ (final_binds, tycon_specs_list,
UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
-> let
used_conids = filter isDataCon (uniqSetToList fvs)
gen_tycons = setToList (mkSet local_tycons `union` mkSet used_gen)
result_specs = addListToFM_C (++) init_specs tycon_specs_list
-
+
uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
- (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
+ (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
cis_warn = init_warn `unionBags` listToBag cis_other
cis_errs = init_errs `unionBags` listToBag cis_unboxed
(if sw_chker D_simplifier_stats then
pprTrace "\nSpecialiser Stats:\n" (ppAboves [
ppBesides [ppStr "SpecCalls ", ppInt spec_calls],
- ppBesides [ppStr "SpecInsts ", ppInt spec_insts],
+ ppBesides [ppStr "SpecInsts ", ppInt spec_insts],
ppSP])
else id)
(final_binds,
SpecData True no_errs local_tycons gen_tycons result_specs
- cis_errs cis_warn tycis_errs)
+ cis_errs cis_warn tycis_errs)
specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _)
= panic "Specialise:specProgram: specialiser called more than once"
--- It may be possible safely to call the specialiser more than once,
+-- It may be possible safely to call the specialiser more than once,
-- but I am not sure there is any benefit in doing so (Patrick)
-- ToDo: What about unfoldings performed after specialisation ???
ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
\begin{code}
-specTyConsAndScope :: SpecM ([PlainCoreBinding], UsageDetails)
- -> SpecM ([PlainCoreBinding], [(TyCon,[(Bool,[Maybe UniType])])], UsageDetails)
+specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
+ -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
specTyConsAndScope scopeM
= scopeM `thenSM` \ (binds, scope_uds) ->
getSwitchCheckerSM `thenSM` \ sw_chkr ->
let
(tycons_cis, gotci_scope_uds)
- = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
+ = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
tycon_specs_list = collectTyConSpecs tycons_cis
in
(if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then
pprTrace "Specialising TyCons:\n"
(ppAboves [ if not (null specs) then
- ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
+ ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
4 (ppAboves (map pp_specs specs))
else ppNil
| (tycon, specs) <- tycon_specs_list])
collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
= (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
where
- (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
- uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
+ (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
+ uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
\end{code}
-
+
%************************************************************************
%* *
\subsection[specTopBinds]{Specialising top-level bindings}
%************************************************************************
\begin{code}
-specTopBinds :: [PlainCoreBinding]
- -> SpecM ([PlainCoreBinding], UsageDetails)
+specTopBinds :: [CoreBinding]
+ -> SpecM ([CoreBinding], UsageDetails)
specTopBinds binds
= spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
fvs_outer = full_fvs `minusUniqSet` (mkUniqSet (concat dbinders_s))
-- It is just to complex to try to sort out top-level dependencies
- -- So we just place all the top-level binds in a *global* CoRec and
+ -- So we just place all the top-level binds in a *global* Rec and
-- leave it to the simplifier to sort it all out ...
in
ASSERT(null dbinds)
- returnSM ([CoRec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
+ returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
where
spec_top_binds (first_bind:rest_binds)
= specBindAndScope True first_bind (
spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
returnSM (ItsABinds rest_binds, rest_uds)
- ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
- returnSM (first_binds ++ rest_binds, all_uds)
+ ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
+ returnSM (first_binds ++ rest_binds, all_uds)
spec_top_binds []
= returnSM ([], emptyUDs)
%************************************************************************
\begin{code}
-specExpr :: PlainCoreExpr
- -> [PlainCoreArg] -- The arguments:
+specExpr :: CoreExpr
+ -> [CoreArg] -- The arguments:
-- TypeArgs are speced
-- ValArgs are unprocessed
- -> SpecM (PlainCoreExpr, -- Result expression with specialised versions installed
+ -> SpecM (CoreExpr, -- Result expression with specialised versions installed
UsageDetails) -- Details of usage of enclosing binders in the result
-- expression.
-specExpr (CoVar v) args
- = lookupId v `thenSM` \ vlookup ->
+specExpr (Var v) args
+ = lookupId v `thenSM` \ vlookup ->
case vlookup of
Lifted vl vu
-> -- Binding has been lifted, need to extract un-lifted value
-- NB: a function binding will never be lifted => args always null
-- i.e. no call instance required or call to be constructed
ASSERT (null args)
- returnSM (bindUnlift vl vu (CoVar vu), singleFvUDs (CoVarAtom vl))
+ returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl))
- NoLift vatom@(CoVarAtom new_v)
+ NoLift vatom@(VarArg new_v)
-> mapSM specArg args `thenSM` \ arg_info ->
mkCallInstance v new_v arg_info `thenSM` \ call_uds ->
mkCall new_v arg_info `thenSM` \ ~(speced, call) ->
in
returnSM (call, tickSpecCall speced uds)
-specExpr expr@(CoLit _) null_args
+specExpr expr@(Lit _) null_args
= ASSERT (null null_args)
returnSM (expr, emptyUDs)
-specExpr (CoCon con tys args) null_args
+specExpr (Con con tys args) null_args
= ASSERT (null null_args)
mapSM specTy tys `thenSM` \ tys ->
mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
mkTyConInstance con tys `thenSM` \ con_uds ->
- returnSM (applyBindUnlifts unlifts (CoCon con tys args),
+ returnSM (applyBindUnlifts unlifts (Con con tys args),
unionUDList args_uds_s `unionUDs` con_uds)
-specExpr (CoPrim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args
+specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args
= ASSERT (null null_args)
ASSERT (null tys)
mapSM specTy arg_tys `thenSM` \ arg_tys ->
specTy res_ty `thenSM` \ res_ty ->
mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
- returnSM (applyBindUnlifts unlifts (CoPrim (CCallOp str is_asm may_gc arg_tys res_ty) tys args),
+ returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) tys args),
unionUDList args_uds_s)
-specExpr (CoPrim prim tys args) null_args
+specExpr (Prim prim tys args) null_args
= ASSERT (null null_args)
mapSM specTy tys `thenSM` \ tys ->
mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
-- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
- returnSM (applyBindUnlifts unlifts (CoPrim prim tys args),
+ returnSM (applyBindUnlifts unlifts (Prim prim tys args),
unionUDList args_uds_s {-`unionUDs` prim_uds-} )
{- ToDo: specPrimOp
specPrimOp :: PrimOp
- -> [UniType]
+ -> [Type]
-> SpecM (PrimOp,
- [UniType],
+ [Type],
UsageDetails)
-- Checks that PrimOp can handle (possibly unboxed) tys passed
-- Errors are dealt with by returning a PrimOp call instance
-- which will result in a cis_errs message
--- ToDo: Deal with checkSpecTyApp for CoPrim in CoreLint
+-- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
-}
-specExpr (CoApp fun arg) args
+specExpr (App fun arg) args
= -- Arg is passed on unprocessed
specExpr fun (ValArg arg : args) `thenSM` \ (expr,uds) ->
returnSM (expr, uds)
specTy ty `thenSM` \ ty ->
specExpr fun (TypeArg ty : args)
-specExpr (CoLam bound_ids body) args
- = specLam bound_ids body args
+specExpr (Lam binder body) (ValArg arg : args)
+ = lookup_arg arg `thenSM` \ arg ->
+ bindId binder arg (specExpr body args)
+ where
+ lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
+ lookup_arg (VarArg v) = lookupId v
+
+specExpr (Lam binder body) []
+ = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
+ returnSM (Lam binder body, uds)
specExpr (CoTyLam tyvar body) (TypeArg ty : args)
= -- Type lambda with argument; argument already spec'd
specExpr body [] `thenSM` \ (body, body_uds) ->
let
(binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
- in
+ in
returnSM (CoTyLam new_tyvar (mkCoLetsNoUnboxed binds_here body), final_uds)
)
-specExpr (CoCase scrutinee alts) args
+specExpr (Case scrutinee alts) args
= specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
- returnSM (CoCase scrutinee alts, scrut_uds `unionUDs` alts_uds)
+ returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
where
- scrutinee_type = typeOfCoreExpr scrutinee
+ scrutinee_type = coreExprType scrutinee
-specExpr (CoLet bind body) args
+specExpr (Let bind body) args
= specBindAndScope False bind (
specExpr body args `thenSM` \ (body, body_uds) ->
returnSM (ItsAnExpr body, body_uds)
) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
-specExpr (CoSCC cc expr) args
+specExpr (SCC cc expr) args
= specExpr expr [] `thenSM` \ (expr, expr_uds) ->
- mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) ->
+ mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) ->
let
scc_expr
= if squashableDictishCcExpr cc expr -- can toss the _scc_
then expr
- else CoSCC cc expr
+ else SCC cc expr
in
- returnSM (applyBindUnlifts unlifts (applyToArgs scc_expr args),
+ returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
unionUDList args_uds_s `unionUDs` expr_uds)
--- ToDo: This may leave some unspeced dictionaries !!
-
--- ToDo: DPH: add stuff here!
+-- ToDo: This may leave some unspec'd dictionaries!!
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-specLam :: [Id] -> PlainCoreExpr -> [PlainCoreArg]
- -> SpecM (PlainCoreExpr, UsageDetails)
-
-specLam [] body args
- = -- All lambdas saturated
- specExpr body args
-
-specLam (binder:binders) body (ValArg arg : args)
- = -- Lambda with an unprocessed argument
- lookup_arg arg `thenSM` \ arg ->
- bindId binder arg (
- specLam binders body args
- )
- where
- lookup_arg (CoLitAtom l) = returnSM (NoLift (CoLitAtom l))
- lookup_arg (CoVarAtom v) = lookupId v
-
-specLam bound_ids body []
- = -- Lambda with no arguments
- specLambdaOrCaseBody bound_ids body [] `thenSM` \ (bound_ids, body, uds) ->
- returnSM (CoLam bound_ids body, uds)
-\end{code}
-
-\begin{code}
specLambdaOrCaseBody :: [Id] -- The binders
- -> PlainCoreExpr -- The body
- -> [PlainCoreArg] -- Its args
+ -> CoreExpr -- The body
+ -> [CoreArg] -- Its args
-> SpecM ([Id], -- New binders
- PlainCoreExpr, -- New body
+ CoreExpr, -- New body
UsageDetails)
specLambdaOrCaseBody bound_ids body args
specExpr body args `thenSM` \ (body, body_uds) ->
let
- -- Dump any dictionary bindings (and call instances)
+ -- Dump any dictionary bindings (and call instances)
-- from the scope which mention things bound here
(binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
in
d.Foo.Int = (op1_Int, op2_Int)
op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
-
+
... op1 {Int Int#} d.Foo.Int 1 3# ...
\end{verbatim}
Though this is still invalid, after further simplification we get:
op1_Int_Int# = opInt1 {Int#}
-
+
Another round of specialisation will result in the specialised
version of op1Int being called directly.
\begin{code}
-specAlts (CoAlgAlts alts deflt) scrutinee_ty args
+specAlts (AlgAlts alts deflt) scrutinee_ty args
= mapSM specTy ty_args `thenSM` \ ty_args ->
mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- returnSM (CoAlgAlts alts deflt,
+ returnSM (AlgAlts alts deflt,
unionUDList alts_uds_s `unionUDs` deflt_uds)
where
-- We use ty_args of scrutinee type to identify specialisation of alternatives
- (_, ty_args, _) = getUniDataTyCon scrutinee_ty
+ (_, ty_args, _) = getAppDataTyCon scrutinee_ty
- specAlgAlt ty_args (con,binders,rhs)
+ specAlgAlt ty_args (con,binders,rhs)
= specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
mkTyConInstance con ty_args `thenSM` \ con_uds ->
returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
-specAlts (CoPrimAlts alts deflt) scrutinee_ty args
+specAlts (PrimAlts alts deflt) scrutinee_ty args
= mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- returnSM (CoPrimAlts alts deflt,
+ returnSM (PrimAlts alts deflt,
unionUDList alts_uds_s `unionUDs` deflt_uds)
where
specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
returnSM ((lit,rhs), uds)
-specDeflt CoNoDefault args = returnSM (CoNoDefault, emptyUDs)
-specDeflt (CoBindDefault binder rhs) args
+specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
+specDeflt (BindDefault binder rhs) args
= specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
- returnSM (CoBindDefault binder rhs, uds)
+ returnSM (BindDefault binder rhs, uds)
\end{code}
%************************************************************************
\begin{code}
-specAtom :: PlainCoreAtom -> SpecM (PlainCoreAtom, UsageDetails,
- PlainCoreExpr -> PlainCoreExpr)
+specAtom :: CoreArg -> SpecM (CoreArg, UsageDetails,
+ CoreExpr -> CoreExpr)
-specAtom (CoLitAtom lit)
- = returnSM (CoLitAtom lit, emptyUDs, id)
+specAtom (LitArg lit)
+ = returnSM (LitArg lit, emptyUDs, id)
-specAtom (CoVarAtom v)
+specAtom (VarArg v)
= lookupId v `thenSM` \ vlookup ->
- case vlookup of
+ case vlookup of
Lifted vl vu
- -> returnSM (CoVarAtom vu, singleFvUDs (CoVarAtom vl), bindUnlift vl vu)
+ -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu)
NoLift vatom
-> returnSM (vatom, singleFvUDs vatom, id)
-specArg :: PlainCoreArg -> SpecM (PlainCoreArg, UsageDetails,
- PlainCoreExpr -> PlainCoreExpr)
+specArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
+ CoreExpr -> CoreExpr)
specArg (ValArg arg) -- unprocessed; spec the atom
= specAtom arg `thenSM` \ (arg, uds, unlift) ->
A classic case of when having a polymorphic recursive function would help!
\begin{code}
-data BindsOrExpr = ItsABinds [PlainCoreBinding]
- | ItsAnExpr PlainCoreExpr
+data BindsOrExpr = ItsABinds [CoreBinding]
+ | ItsAnExpr CoreExpr
\end{code}
\begin{code}
-specBindAndScope
+specBindAndScope
:: Bool -- True <=> a top level group
- -> PlainCoreBinding -- As yet unprocessed
+ -> CoreBinding -- As yet unprocessed
-> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
- -> SpecM ([PlainCoreBinding], -- Processed
+ -> SpecM ([CoreBinding], -- Processed
BindsOrExpr, -- Combined result
UsageDetails) -- Usage details of the whole lot
-specBindAndScope top_lev bind scopeM
+specBindAndScope top_lev bind scopeM
= cloneLetBinders top_lev (is_rec bind) binders
`thenSM` \ (new_binders, clone_infos) ->
-- in which case we see if they correspond to any call-instances
-- we have from processing the scope
- if not top_lev && all (isDictTy . getIdUniType) binders
+ if not top_lev && all (isDictTy . idType) binders
then
-- Ha! A group of local dictionary bindings
-- Process their scope
scopeM `thenSM` \ (thing, scope_uds) ->
- let
+ let
-- Add the bindings to the current stuff
final_uds = addDictBinds new_binders bind rhs_uds scope_uds
in
fixSM (\ ~(_, _, _, rec_spec_infos) ->
- bindSpecIds binders clone_infos rec_spec_infos (
+ bindSpecIds binders clone_infos rec_spec_infos (
-- It's ok to have new binders in scope in
-- non-recursive decls too, cos name shadowing is gone by now
let
(call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
- equiv_ciss = equivClasses cmpCI_tys call_insts
- inst_cis = map head equiv_ciss
+ equiv_ciss = equivClasses cmpCI_tys call_insts
+ inst_cis = map head equiv_ciss
in
-- Do the bindings themselves
-- Create any necessary instances
instBind top_lev new_binders bind equiv_ciss inst_cis
- `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
+ `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
let
-- NB: dumpUDs only worries about new_binders since the free var
-- have already been dumped by specBind and instBind
let
(scope_dict_binds, final_scope_uds)
- = dumpUDs gotci_scope_uds False False [] new_binders []
+ = dumpUDs gotci_scope_uds False False [] new_binders []
in
([spec_bind] ++ inst_binds ++ scope_dict_binds,
spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
-- inst_uds comes last, because there may be dict bindings
- -- floating outward in scope_uds which are mentioned
+ -- floating outward in scope_uds which are mentioned
-- in the call-instances, and hence in spec_uds.
-- This ordering makes sure that the precedence order
-- among the dict bindings finally floated out is maintained.
in
returnSM (final_binds, thing, final_uds, spec_infos)
- )
+ )
) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
returnSM (binds, thing, final_uds)
where
binders = bindersOf bind
- is_rec (CoNonRec _ _) = False
+ is_rec (NonRec _ _) = False
is_rec _ = True
\end{code}
\begin{code}
specBind :: Bool -> Bool -> [Id] -> [CallInstance]
- -> PlainCoreBinding
- -> SpecM (PlainCoreBinding, UsageDetails)
+ -> CoreBinding
+ -> SpecM (CoreBinding, UsageDetails)
-- The UsageDetails returned has already had stuff to do with this group
-- of binders deleted; that's why new_binders is passed in.
-specBind top_lev floating new_binders inst_cis (CoNonRec binder rhs)
+specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
= specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
`thenSM` \ ((binder,rhs), rhs_uds) ->
- returnSM (CoNonRec binder rhs, rhs_uds)
+ returnSM (NonRec binder rhs, rhs_uds)
-specBind top_lev floating new_binders inst_cis (CoRec pairs)
+specBind top_lev floating new_binders inst_cis (Rec pairs)
= mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
`thenSM` \ (pairs, rhs_uds_s) ->
- returnSM (CoRec pairs, unionUDList rhs_uds_s)
+ returnSM (Rec pairs, unionUDList rhs_uds_s)
specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
- -> (Id,PlainCoreExpr)
- -> SpecM ((Id,PlainCoreExpr), UsageDetails)
+ -> (Id,CoreExpr)
+ -> SpecM ((Id,CoreExpr), UsageDetails)
specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
= lookupId binder `thenSM` \ blookup ->
is_specid = maybeToBool specid_maybe_maybe
Just specinfo_maybe = specid_maybe_maybe
specid_with_info = maybeToBool specinfo_maybe
- Just spec_info = specinfo_maybe
+ Just spec_info = specinfo_maybe
-- If we have a SpecInfo stored in a SpecPragmaId binder
-- it will contain a SpecInfo with an explicit SpecId
ASSERT(toplevelishId orig_id) -- must not be cloned!
explicitCI orig_id spec_tys spec_info
else
- emptyUDs
+ emptyUDs
- -- For a local binding we dump the usage details, creating
+ -- For a local binding we dump the usage details, creating
-- any local dict bindings required
-- At the top-level the uds will be dumped in specBindAndScope
-- and the dict bindings made *global*
([], rhs_uds)
in
case blookup of
- Lifted lift_binder unlift_binder
- -> -- We may need to record an unboxed instance of
+ Lifted lift_binder unlift_binder
+ -> -- We may need to record an unboxed instance of
-- the _Lift data type in the usage details
- mkTyConInstance liftDataCon [getIdUniType unlift_binder]
+ mkTyConInstance liftDataCon [idType unlift_binder]
`thenSM` \ lift_uds ->
returnSM ((lift_binder,
- mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
+ mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
- NoLift (CoVarAtom binder)
+ NoLift (VarArg binder)
-> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
final_uds `unionUDs` pragma_uds)
\end{code}
| all same_overloading other_binders
= -- For each call_inst, build an instance
- mapAndUnzip3SM do_this_class equiv_ciss
+ mapAndUnzip3SM do_this_class equiv_ciss
`thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
-- Add in the remaining UDs
- returnSM (catMaybes inst_binds,
+ returnSM (catMaybes inst_binds,
unionUDList inst_uds_s,
spec_infos
)
then pprTrace "dumpCIs: not same overloading ... top level \n"
else (\ x y -> y)
) (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
- 4 (ppAboves [ppAboves (map (pprUniType PprDebug . getIdUniType) new_ids),
+ 4 (ppAboves [ppAboves (map (pprType PprDebug . idType) new_ids),
ppAboves (map pprCI (concat equiv_ciss))]))
(returnSM ([], emptyUDs, []))
do_cis = head (normal_cis ++ explicit_cis)
-- must choose a normal_cis in preference since dict_args will
-- not be defined for an explicit_cis
-
+
-- same_overloading tests whether the types of all the binders
-- are "compatible"; ie have the same type and dictionary abstractions
-- Almost always this is the case, because a recursive group is abstracted
-- mutually recursive!
same_overloading :: Id -> Bool
- same_overloading id
- = no_of_tyvars == length this_id_tyvars -- Same no of tyvars
- &&
- no_of_dicts == length this_id_class_tyvar_pairs -- Same no of vdicts
- &&
- and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs) -- Same overloading
+ same_overloading id
+ = no_of_tyvars == length this_id_tyvars
+ -- Same no of tyvars
+ && no_of_dicts == length this_id_class_tyvar_pairs
+ -- Same no of vdicts
+ && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
+ && length class_tyvar_pairs == length this_id_class_tyvar_pairs
+ -- Same overloading
where
(this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
- same_ov (clas1,tyvar1) (clas2,tyvar2)
+ same_ov (clas1,tyvar1) (clas2,tyvar2)
= clas1 == clas2 &&
tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
\end{code}
The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat)
- SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
+ SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
Based on this SpecInfo, a call instance of f
-> Bool -- Top level binders?
-> [CallInstance] -- Instantiated call insts for binders
-> [Id] -- New binders
- -> PlainCoreBinding -- Unprocessed
- -> SpecM (Maybe PlainCoreBinding, -- Instantiated version of input
+ -> CoreBinding -- Unprocessed
+ -> SpecM (Maybe CoreBinding, -- Instantiated version of input
UsageDetails,
[Maybe SpecInfo] -- One for each id in the original binding
)
let
-- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
-- which correspond to unspeciailsed args
- arg_tys :: [UniType]
+ arg_tys :: [Type]
(_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
- args :: [PlainCoreArg]
+ args :: [CoreArg]
args = map TypeArg arg_tys ++ dict_args
(new_id:_) = new_ids
(spec_id:_) = spec_ids
- do_bind (CoNonRec orig_id rhs)
+ do_bind (NonRec orig_id rhs)
= do_one_rhs (spec_id, new_id, (orig_id,rhs))
`thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
case maybe_spec of
- Just (spec_id, rhs) -> returnSM (Just (CoNonRec spec_id rhs), rhs_uds, [spec_info])
+ Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
- do_bind (CoRec pairs)
+ do_bind (Rec pairs)
= mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
`thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
- returnSM (Just (CoRec (catMaybes maybe_pairs)),
+ returnSM (Just (Rec (catMaybes maybe_pairs)),
unionUDList rhss_uds_s, spec_infos)
do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
-- Avoid duplicating a spec which has already been created ...
- -- This can arise in a CoRec involving a dfun for which a
+ -- This can arise in a Rec involving a dfun for which a
-- a specialised instance has been created but specialisation
- -- "required" by one of the other Ids in the CoRec
+ -- "required" by one of the other Ids in the Rec
| top_lev && maybeToBool lookup_orig_spec
= (if sw_chkr SpecialiseTrace
then trace_nospec " Exists: " exists_id
(if sw_chkr SpecialiseTrace
then trace_nospec " Explicit: " explicit_id
else id) (
-
+
returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
)
| otherwise
= ASSERT (no_of_dicts_to_specialise == length dict_args)
specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
- let
- -- For a local binding we dump the usage details, creating
- -- any local dict bindings required
- -- At the top-level the uds will be dumped in specBindAndScope
- -- and the dict bindings made *global*
-
- (local_dict_binds, final_uds)
- = if not top_lev then
+ let
+ -- For a local binding we dump the usage details, creating
+ -- any local dict bindings required
+ -- At the top-level the uds will be dumped in specBindAndScope
+ -- and the dict bindings made *global*
+
+ (local_dict_binds, final_uds)
+ = if not top_lev then
dumpUDs inst_uds False False inst_cis new_ids []
- else
+ else
([], inst_uds)
-
- spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
+
+ spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
in
- if isUnboxedDataType (getIdUniType spec_id) then
- ASSERT (null poly_tyvars)
- liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
- mkTyConInstance liftDataCon [getIdUniType unlift_spec_id]
+ if isUnboxedDataType (idType spec_id) then
+ ASSERT (null poly_tyvars)
+ liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
+ mkTyConInstance liftDataCon [idType unlift_spec_id]
`thenSM` \ lift_uds ->
- returnSM (Just (lift_spec_id,
- mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
- tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
+ returnSM (Just (lift_spec_id,
+ mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
+ tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
else
- returnSM (Just (spec_id,
+ returnSM (Just (spec_id,
mkCoLetsNoUnboxed local_dict_binds (mkCoTyLam poly_tyvars inst_rhs)),
- tickSpecInsts final_uds, spec_info)
+ tickSpecInsts final_uds, spec_info)
where
lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
Just (exists_id, _, _) = lookup_orig_spec
in
(if sw_chkr SpecialiseTrace then
pprTrace "Specialising:"
- (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
+ (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
4 (ppAboves [
- ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
+ ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
if isExplicitCI do_cis then ppNil else
ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)],
- ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]]))
+ ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]]))
else id) (
-
+
do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
returnSM (maybe_inst_bind, inst_uds, spec_infos)
)
where
pp_dict (ValArg d) = ppr PprDebug d
- pp_ty t = pprParendUniType PprDebug t
+ pp_ty t = pprParendType PprDebug t
do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
do_the_wotsit tyvars (Just ty) = (tyvars, ty)
%************************************************************************
\begin{code}
-mkCallInstance :: Id
+mkCallInstance :: Id
-> Id
- -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
+ -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
-> SpecM UsageDetails
mkCallInstance id new_id []
| otherwise
= getSwitchCheckerSM `thenSM` \ sw_chkr ->
let
- spec_overloading = sw_chkr SpecialiseOverloaded
- spec_unboxed = sw_chkr SpecialiseUnboxed
- spec_all = sw_chkr SpecialiseAll
+ spec_overloading = sw_chkr SpecialiseOverloaded
+ spec_unboxed = sw_chkr SpecialiseUnboxed
+ spec_all = sw_chkr SpecialiseAll
(tyvars, class_tyvar_pairs) = getIdOverloading id
= (record, lookup, spec_tys)
where
spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
- (mkConstraintVector id) tys
+ (mkConstraintVector id) tys
record = any (not . isTyVarTy) (catMaybes spec_tys)
in
if (not enough_args) then
pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
- (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
+ (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
else
case record_spec id tys of
(False, _, _)
- -> -- pprTrace "CallInst:NotReqd\n"
+ -> -- pprTrace "CallInst:NotReqd\n"
-- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
(returnSM emptyUDs)
returnSM emptyUDs
else
-- pprTrace "CallInst:Reqd\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
-- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
-- ppCat (map (ppr PprDebug) dicts)]])
(returnSM (singleCI new_id spec_tys dicts))
-- NB: const method is top-level so spec_id will not be cloned
case record_spec spec_id tys_left of
(False, _, _)
- -> -- pprTrace "CallInst:Exists\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -> -- pprTrace "CallInst:Exists\n"
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
-- ppCat [ppStr "->", ppr PprDebug spec_id,
-- ppr PprDebug (tys_left ++ drop toss dicts)]])
(returnSM emptyUDs)
(True, Nothing, spec_tys)
-> -- pprTrace "CallInst:Exists:Reqd\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
-- ppCat [ppStr "->", ppr PprDebug spec_id,
-- ppr PprDebug (tys_left ++ drop toss dicts)],
-- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
(returnSM (singleCI spec_id spec_tys (drop toss dicts)))
(True, Just (spec_spec_id, tys_left_left, toss_toss), _)
- -> -- pprTrace "CallInst:Exists:Exists\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -> -- pprTrace "CallInst:Exists:Exists\n"
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
-- ppCat [ppStr "->", ppr PprDebug spec_id,
-- ppr PprDebug (tys_left ++ drop toss dicts)],
-- ppCat [ppStr "->", ppr PprDebug spec_spec_id,
(returnSM emptyUDs)
else
- -- pprTrace "CallInst:Exists\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -- pprTrace "CallInst:Exists\n"
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
-- ppCat [ppStr "->", ppr PprDebug spec_id,
-- ppr PprDebug (tys_left ++ drop toss dicts)]])
(returnSM emptyUDs)
-take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args)
+take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args)
= case take_type_args tyvars class_tyvar_pairs args of
Nothing -> Nothing
Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
take_type_args (_:tyvars) class_tyvar_pairs []
= Nothing
-take_type_args [] class_tyvar_pairs args
+take_type_args [] class_tyvar_pairs args
= case take_dict_args class_tyvar_pairs args of
Nothing -> Nothing
Just (dicts, others) -> Just ([], dicts, others)
-take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args)
+take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args)
= case take_dict_args class_tyvar_pairs args of
Nothing -> Nothing
Just (dicts, others) -> Just (dict:dicts, others)
\begin{code}
mkCall :: Id
- -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
- -> SpecM (Bool, PlainCoreExpr)
+ -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
+ -> SpecM (Bool, CoreExpr)
mkCall new_id args
| maybeToBool (isSuperDictSelId_maybe new_id)
-- have been specialised. We only do this to keep core-lint happy.
= let
Just (_, super_class) = isSuperDictSelId_maybe new_id
- super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
+ super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
Nothing -> panic "Specialise:mkCall:SuperDictId"
Just id -> id
in
- returnSM (False, CoVar super_dict_id)
+ returnSM (False, Var super_dict_id)
| otherwise
= case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
returnSM (False, unspec_call)
)
- Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
+ Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
-> let
-- It may be necessary to specialsie a constant method spec_id again
(spec_id, tys_left, dicts_to_toss) =
(True, Nothing) -> spec_1_details
(True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
-> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
-
+
args_left = toss_dicts dicts_to_toss val_args
in
checkSpecOK new_id ty_args spec_id tys_left (
-- These top level defns should have been lifted.
-- We must add code to unlift such a spec_id.
- if isUnboxedDataType (getIdUniType spec_id) then
+ if isUnboxedDataType (idType spec_id) then
ASSERT (null tys_left && null args_left)
if toplevelishId spec_id then
liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
returnSM (True, bindUnlift lift_spec_id unlift_spec_id
- (CoVar unlift_spec_id))
+ (Var unlift_spec_id))
else
pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
(ppCat [ppr PprDebug new_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) ty_args),
+ ppInterleave ppNil (map (pprParendType PprDebug) ty_args),
ppStr "==>",
ppr PprDebug spec_id])
else
let
(vals_left, _, unlifts_left) = unzip3 args_left
- applied_tys = mkCoTyApps (CoVar spec_id) tys_left
- applied_vals = applyToArgs applied_tys vals_left
+ applied_tys = mkCoTyApps (Var spec_id) tys_left
+ applied_vals = mkGenApp applied_tys vals_left
in
returnSM (True, applyBindUnlifts unlifts_left applied_vals)
)
where
(tys_and_vals, _, unlifts) = unzip3 args
- unspec_call = applyBindUnlifts unlifts (applyToArgs (CoVar new_id) tys_and_vals)
+ unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
-- ty_args is the types at the front of the arg list
\end{code}
\begin{code}
-checkUnspecOK :: Id -> [UniType] -> a -> a
+checkUnspecOK :: Id -> [Type] -> a -> a
checkUnspecOK check_id tys
= if isLocallyDefined check_id && any isUnboxedDataType tys
then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
(ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) tys)])
+ ppInterleave ppNil (map (pprParendType PprDebug) tys)])
else id
-checkSpecOK :: Id -> [UniType] -> Id -> [UniType] -> a -> a
+checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
checkSpecOK check_id tys spec_id tys_left
= if any isUnboxedDataType tys_left
then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
(ppAboves [ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) tys)],
+ ppInterleave ppNil (map (pprParendType PprDebug) tys)],
ppCat [ppr PprDebug spec_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) tys_left)]])
+ ppInterleave ppNil (map (pprParendType PprDebug) tys_left)]])
else id
\end{code}
\begin{code}
mkTyConInstance :: Id
- -> [UniType]
+ -> [Type]
-> SpecM UsageDetails
mkTyConInstance con tys
= recordTyConInst con tys `thenSM` \ record_inst ->
case record_inst of
Nothing -- No TyCon instance
- -> -- pprTrace "NoTyConInst:"
+ -> -- pprTrace "NoTyConInst:"
-- (ppCat [ppr PprDebug tycon, ppStr "at",
-- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
(returnSM (singleConUDs con))
-> -- pprTrace "TyConInst:"
-- (ppCat [ppr PprDebug tycon, ppStr "at",
-- ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
- -- ppBesides [ppStr "(",
+ -- ppBesides [ppStr "(",
-- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
-- ppStr ")"]])
(returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
\begin{code}
recordTyConInst :: Id
- -> [UniType]
- -> SpecM (Maybe [Maybe UniType])
+ -> [Type]
+ -> SpecM (Maybe [Maybe Type])
recordTyConInst con tys
= let
- spec_tys = specialiseConstrTys tys
+ spec_tys = specialiseConstrTys tys
do_tycon_spec = maybeToBool (firstJust spec_tys)
- spec_exists = maybeToBool (lookupSpecEnv
- (getIdSpecialisation con)
+ spec_exists = maybeToBool (lookupSpecEnv
+ (getIdSpecialisation con)
tys)
in
-- pprTrace "ConSpecExists?: "
inherited: control flags and
recordInst functions with flags cached
- environment mapping tyvars to types
+ environment mapping tyvars to types
environment mapping Ids to Atoms
-
+
threaded in and out: unique supply
\begin{code}
= (GlobalSwitch -> Bool)
-> TypeEnv
-> SpecIdEnv
- -> SplitUniqSupply
+ -> UniqSupply
-> result
initSM m sw_chker uniqs
\begin{code}
newSpecIds :: [Id] -- The id of which to make a specialised version
- -> [Maybe UniType] -- Specialise to these types
+ -> [Maybe Type] -- Specialise to these types
-> Int -- No of dicts to specialise
-> SpecM [Id]
= [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
| (id,uniq) <- new_ids `zip` uniqs ]
where
- uniqs = getSUniques (length new_ids) us
- spec_id_ty id = specialiseTy (getIdUniType id) maybe_tys dicts_to_ignore
+ uniqs = getUniques (length new_ids) us
+ spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
newTyVars :: Int -> SpecM [TyVar]
newTyVars n sw_chkr tvenv idenv us
= map mkPolySysTyVar uniqs
where
- uniqs = getSUniques n us
+ uniqs = getUniques n us
\end{code}
@cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
As well as returning the list of cloned @Id@s they also return a list of
@CloneInfo@s which the original binders should be bound to.
-
+
\begin{code}
cloneLambdaOrCaseBinders :: [Id] -- Old binders
-> SpecM ([Id], [CloneInfo]) -- New ones
cloneLambdaOrCaseBinders old_ids sw_chkr tvenv idenv us
= let
- uniqs = getSUniques (length old_ids) us
+ uniqs = getUniques (length old_ids) us
in
- unzip (zipWith clone_it old_ids uniqs)
+ unzip (zipWithEqual clone_it old_ids uniqs)
where
clone_it old_id uniq
- = (new_id, NoLift (CoVarAtom new_id))
+ = (new_id, NoLift (VarArg new_id))
where
new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us
= let
- uniqs = getSUniques (2 * length old_ids) us
+ uniqs = getUniques (2 * length old_ids) us
in
unzip (clone_them old_ids uniqs)
where
clone_them (old_id:olds) (u1:u2:uniqs)
| top_lev
= (old_id,
- NoLift (CoVarAtom old_id)) : clone_rest
+ NoLift (VarArg old_id)) : clone_rest
-- Don't clone if it is a top-level thing. Why not?
- -- (a) we don't want to change the uniques
+ -- (a) we don't want to change the uniques
-- on such things (see TopLevId in Id.lhs)
-- (b) we don't have to be paranoid about name capture
-- (c) the thing is polymorphic so no need to subst
then (lifted_id,
Lifted lifted_id unlifted_id) : clone_rest
else (new_id,
- NoLift (CoVarAtom new_id)) : clone_rest
+ NoLift (VarArg new_id)) : clone_rest
- where
+ where
clone_rest = clone_them olds uniqs
new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
- new_ty = getIdUniType new_id
- old_ty = getIdUniType old_id
+ new_ty = idType new_id
+ old_ty = idType old_id
(lifted_id, unlifted_id) = mkLiftedId new_id u2
cloneTyVarSM old_tyvar sw_chkr tvenv idenv us
= let
- uniq = getSUnique us
+ uniq = getUnique us
in
cloneTyVar old_tyvar uniq -- new_tyvar
-> [[Maybe SpecInfo]] -- Corresponding specialisations
-- Each sub-list corresponds to a different type,
-- and contains one Maybe spec_info for each id
- -> SpecM thing
+ -> SpecM thing
-> SpecM thing
bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us
-- The important thing here is that we are *lazy* in spec_infos
mk_old_to_clone [] [] _ = []
mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
- = (old, add_spec_info clone) :
+ = (old, add_spec_info clone) :
mk_old_to_clone rest_olds rest_clones spec_infos_rest
where
- add_spec_info (NoLift (CoVarAtom new))
- = NoLift (CoVarAtom (new `addIdSpecialisation`
- (mkSpecEnv spec_infos_this_id)))
+ add_spec_info (NoLift (VarArg new))
+ = NoLift (VarArg (new `addIdSpecialisation`
+ (mkSpecEnv spec_infos_this_id)))
add_spec_info lifted
= lifted -- no specialised instances for unboxed lifted values
spec_infos_rest = map tail spec_infos
-bindTyVar :: TyVar -> UniType -> SpecM thing -> SpecM thing
+bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
bindTyVar tyvar ty specm sw_chkr tvenv idenv us
= specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
\begin{code}
lookupId :: Id -> SpecM CloneInfo
-lookupId id sw_chkr tvenv idenv us
+lookupId id sw_chkr tvenv idenv us
= case lookupIdEnv idenv id of
- Nothing -> NoLift (CoVarAtom id)
+ Nothing -> NoLift (VarArg id)
Just info -> info
\end{code}
\begin{code}
-specTy :: UniType -> SpecM UniType -- Apply the current type envt to the type
+specTy :: Type -> SpecM Type -- Apply the current type envt to the type
-specTy ty sw_chkr tvenv idenv us
+specTy ty sw_chkr tvenv idenv us
= applyTypeEnvToTy tvenv ty
\end{code}
liftId :: Id -> SpecM (Id, Id)
liftId id sw_chkr tvenv idenv us
= let
- uniq = getSUnique us
+ uniq = getUnique us
in
mkLiftedId id uniq
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CoreToStg where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgExpr, StgRhs, UpdateFlag)
-import TyVar(TyVar)
-import UniType(UniType)
-data CoreBinding a b
-data CoreExpr a b
-data Id
-data SplitUniqSupply
-data StgBinderInfo
-data StgBinding a b
-data StgRhs a b
-topCoreBindsToStg :: SplitUniqSupply -> [CoreBinding Id Id] -> [StgBinding Id Id]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
#include "HsVersions.h"
module CoreToStg (
- topCoreBindsToStg,
+ topCoreBindsToStg
-- and to make the interface self-sufficient...
- SplitUniqSupply, Id, CoreExpr, CoreBinding, StgBinding,
- StgRhs, StgBinderInfo
) where
-import PlainCore -- input
import AnnCoreSyn -- intermediate form on which all work is done
import StgSyn -- output
-import SplitUniq
-import Unique -- the UniqueSupply monadery used herein
+import UniqSupply
-import AbsPrel ( unpackCStringId, unpackCString2Id, stringTy,
+import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy,
integerTy, rationalTy, ratioDataCon,
PrimOp(..), -- For Int2IntegerOp etc
integerZeroId, integerPlusOneId,
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( isPrimType, isLeakFreeType, getUniDataTyCon )
+import Type ( isPrimType, isLeakFreeType, getAppDataTyCon )
import Bag -- Bag operations
-import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) -- ToDo: its use is ugly...
+import Literal ( mkMachInt, Literal(..) ) -- ToDo: its use is ugly...
import CostCentre ( noCostCentre, CostCentre )
-import Id ( mkSysLocal, getIdUniType, isBottomingId
+import Id ( mkSysLocal, idType, isBottomingId
IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
)
-import IdEnv
import Maybes ( Maybe(..), catMaybes )
import Outputable ( isExported )
import Pretty -- debugging only!
-import SpecTyFuns ( mkSpecialisedCon )
+import SpecUtils ( mkSpecialisedCon )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import Util
\end{code}
* We do *not* pin on the correct free/live var info; that's done later.
Instead we use bOGUS_LVS and _FVS as a placeholder.
-* We convert case x of {...; x' -> ...x'...}
+* We convert case x of {...; x' -> ...x'...}
to
case x of {...; _ -> ...x... }
with \tr{y}.
\begin{code}
-type StgEnv = IdEnv PlainStgAtom
+type StgEnv = IdEnv StgArg
\end{code}
No free/live variable information is pinned on in this pass; it's added
we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
\begin{code}
-bOGUS_LVs :: PlainStgLiveVars
+bOGUS_LVs :: StgLiveVars
bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
bOGUS_FVs :: [Id]
\end{code}
\begin{code}
-topCoreBindsToStg :: SplitUniqSupply -- name supply
- -> [PlainCoreBinding] -- input
- -> [PlainStgBinding] -- output
+topCoreBindsToStg :: UniqSupply -- name supply
+ -> [CoreBinding] -- input
+ -> [StgBinding] -- output
topCoreBindsToStg us core_binds
- = case (initSUs us (binds_to_stg nullIdEnv core_binds)) of
+ = case (initUs us (binds_to_stg nullIdEnv core_binds)) of
(_, stuff) -> stuff
where
- binds_to_stg :: StgEnv -> [PlainCoreBinding] -> SUniqSM [PlainStgBinding]
+ binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
- binds_to_stg env [] = returnSUs []
+ binds_to_stg env [] = returnUs []
binds_to_stg env (b:bs)
- = do_top_bind env b `thenSUs` \ (new_b, new_env, float_binds) ->
- binds_to_stg new_env bs `thenSUs` \ new_bs ->
- returnSUs (bagToList float_binds ++ -- Literals
- new_b ++
- new_bs)
+ = do_top_bind env b `thenUs` \ (new_b, new_env, float_binds) ->
+ binds_to_stg new_env bs `thenUs` \ new_bs ->
+ returnUs (bagToList float_binds ++ -- Literals
+ new_b ++
+ new_bs)
- do_top_bind env bind@(CoRec pairs)
+ do_top_bind env bind@(Rec pairs)
= coreBindToStg env bind
- do_top_bind env bind@(CoNonRec var rhs)
- = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds) ->
+ do_top_bind env bind@(NonRec var rhs)
+ = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds) ->
{- TESTING:
let
ppr_blah xs = ppInterleave ppComma (map pp_x xs)
pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
-}
case stg_binds of
- [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
+ [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
-- Mega-special case; there's still a binding there
-- no fvs (of course), *no args*, "let" rhs
- let
+ let
(extra_float_binds, rhs_body') = seek_liftable [] rhs_body
- in
- returnSUs (extra_float_binds ++
+ in
+ returnUs (extra_float_binds ++
[StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
new_env,
float_binds)
- other -> returnSUs (stg_binds, new_env, float_binds)
+ other -> returnUs (stg_binds, new_env, float_binds)
--------------------
-- HACK: look for very simple, obviously-liftable bindings
-- that can come up to the top level; those that couldn't
-- 'cause they were big-lambda constrained in the Core world.
- seek_liftable :: [PlainStgBinding] -- accumulator...
- -> PlainStgExpr -- look for top-lev liftables
- -> ([PlainStgBinding], PlainStgExpr) -- result
+ seek_liftable :: [StgBinding] -- accumulator...
+ -> StgExpr -- look for top-lev liftables
+ -> ([StgBinding], StgExpr) -- result
seek_liftable acc expr@(StgLet inner_bind body)
| is_liftable inner_bind
--------------------
is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
= not (null args) -- it's manifestly a function...
- || isLeakFreeType [] (getIdUniType binder)
+ || isLeakFreeType [] (idType binder)
|| is_whnf body
-- ToDo: use a decent manifestlyWHNF function for STG?
where
- is_whnf (StgConApp _ _ _) = True
- is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v
+ is_whnf (StgCon _ _ _) = True
+ is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v
is_whnf other = False
is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
\begin{code}
coreBindToStg :: StgEnv
- -> PlainCoreBinding
- -> SUniqSM ([PlainStgBinding], -- Empty or singleton
+ -> CoreBinding
+ -> UniqSM ([StgBinding], -- Empty or singleton
StgEnv, -- New envt
- Bag PlainStgBinding) -- Floats
+ Bag StgBinding) -- Floats
-coreBindToStg env (CoNonRec binder rhs)
- = coreRhsToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
+coreBindToStg env (NonRec binder rhs)
+ = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
let
-- Binds to return if RHS is trivial
[] -- Discard it
in
case stg_rhs of
- StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
+ StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
-- Trivial RHS, so augment envt, and ditch the binding
- returnSUs (triv_binds, new_env, rhs_binds)
+ returnUs (triv_binds, new_env, rhs_binds)
where
new_env = addOneToIdEnv env binder atom
-
- StgRhsCon cc con_id [] ->
+
+ StgRhsCon cc con_id [] ->
-- Trivial RHS, so augment envt, and ditch the binding
- returnSUs (triv_binds, new_env, rhs_binds)
+ returnUs (triv_binds, new_env, rhs_binds)
where
- new_env = addOneToIdEnv env binder (StgVarAtom con_id)
+ new_env = addOneToIdEnv env binder (StgVarArg con_id)
other -> -- Non-trivial RHS, so don't augment envt
- returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds)
+ returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
-coreBindToStg env (CoRec pairs)
+coreBindToStg env (Rec pairs)
= -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
-- (possibly ToDo)
let
(binders, rhss) = unzip pairs
in
- mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) ->
- returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
+ mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
+ returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
\end{code}
%************************************************************************
\begin{code}
-coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding)
+coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
coreRhsToStg env core_rhs
- = coreExprToStg env core_rhs `thenSUs` \ (stg_expr, stg_binds) ->
+ = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) ->
let stg_rhs = case stg_expr of
- StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom var2) [] _)
+ StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
| var1 == var2 -> rhs
-- This curious stuff is to unravel what a lambda turns into
-- We have to do it this way, rather than spot a lambda in the
-- incoming rhs
- StgConApp con args _ -> StgRhsCon noCostCentre con args
+ StgCon con args _ -> StgRhsCon noCostCentre con args
other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc -- safe
- bOGUS_FVs
- Updatable -- Be pessimistic
- []
- stg_expr
+ bOGUS_FVs
+ Updatable -- Be pessimistic
+ []
+ stg_expr
in
- returnSUs (stg_rhs, stg_binds)
+ returnUs (stg_rhs, stg_binds)
\end{code}
tARGET_MIN_INT = -536870912
tARGET_MAX_INT = 536870912
-litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
+litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
-litToStgAtom (NoRepStr s)
- = newStgVar stringTy `thenSUs` \ var ->
+litToStgArg (NoRepStr s)
+ = newStgVar stringTy `thenUs` \ var ->
let
rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc -- safe
bOGUS_FVs
- Updatable -- OLD: ReEntrant (see note below)
+ Updatable -- WAS: ReEntrant (see note below)
[] -- No arguments
val
-- We used not to update strings, so that they wouldn't clog up the heap,
--- but instead be unpacked each time. But on some programs that costs a lot
+-- but instead be unpacked each time. But on some programs that costs a lot
-- [eg hpg], so now we update them.
val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
- StgApp (StgVarAtom unpackCString2Id)
- [StgLitAtom (MachStr s),
- StgLitAtom (mkMachInt (toInteger (_LENGTH_ s)))]
+ StgApp (StgVarArg unpackCString2Id)
+ [StgLitArg (MachStr s),
+ StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
bOGUS_LVs
else
- StgApp (StgVarAtom unpackCStringId)
- [StgLitAtom (MachStr s)]
+ StgApp (StgVarArg unpackCStringId)
+ [StgLitArg (MachStr s)]
bOGUS_LVs
in
- returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
+ returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
where
is_NUL c = c == '\0'
-litToStgAtom (NoRepInteger i)
+litToStgArg (NoRepInteger i)
-- extremely convenient to look out for a few very common
-- Integer literals!
- | i == 0 = returnSUs (StgVarAtom integerZeroId, emptyBag)
- | i == 1 = returnSUs (StgVarAtom integerPlusOneId, emptyBag)
- | i == 2 = returnSUs (StgVarAtom integerPlusTwoId, emptyBag)
- | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag)
+ | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag)
+ | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag)
+ | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag)
+ | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
| otherwise
- = newStgVar integerTy `thenSUs` \ var ->
+ = newStgVar integerTy `thenUs` \ var ->
let
rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc -- safe
[] -- No arguments
val
- val
+ val
| i > tARGET_MIN_INT && i < tARGET_MAX_INT
= -- Start from an Int
- StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs
+ StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
| otherwise
= -- Start from a string
- StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs
+ StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
in
- returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
+ returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
-litToStgAtom (NoRepRational r)
- = litToStgAtom (NoRepInteger (numerator r)) `thenSUs` \ (num_atom, binds1) ->
- litToStgAtom (NoRepInteger (denominator r)) `thenSUs` \ (denom_atom, binds2) ->
- newStgVar rationalTy `thenSUs` \ var ->
+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
+ ratioDataCon -- Constructor
[num_atom, denom_atom]
in
- returnSUs (StgVarAtom var, binds1 `unionBags`
+ returnUs (StgVarArg var, binds1 `unionBags`
binds2 `unionBags`
unitBag (StgNonRec var rhs))
-litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag)
+litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
\end{code}
%************************************************************************
\begin{code}
-coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
+coreAtomToStg :: StgEnv -> CoreArg -> UniqSM (StgArg, Bag StgBinding)
-coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag)
-coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit
+coreAtomToStg env (VarArg var) = returnUs (stgLookup env var, emptyBag)
+coreAtomToStg env (LitArg lit) = litToStgArg lit
\end{code}
There's not anything interesting we can ASSERT about \tr{var} if it
isn't in the StgEnv. (WDP 94/06)
\begin{code}
-stgLookup :: StgEnv -> Id -> PlainStgAtom
+stgLookup :: StgEnv -> Id -> StgArg
stgLookup env var = case (lookupIdEnv env var) of
- Nothing -> StgVarAtom var
+ Nothing -> StgVarArg var
Just atom -> atom
\end{code}
%************************************************************************
\begin{code}
-coreExprToStg :: StgEnv
- -> PlainCoreExpr
- -> SUniqSM (PlainStgExpr, -- Result
- Bag PlainStgBinding) -- Float these to top level
+coreExprToStg :: StgEnv
+ -> CoreExpr
+ -> UniqSM (StgExpr, -- Result
+ Bag StgBinding) -- Float these to top level
\end{code}
\begin{code}
-coreExprToStg env (CoLit lit)
- = litToStgAtom lit `thenSUs` \ (atom, binds) ->
- returnSUs (StgApp atom [] bOGUS_LVs, binds)
+coreExprToStg env (Lit lit)
+ = litToStgArg lit `thenUs` \ (atom, binds) ->
+ returnUs (StgApp atom [] bOGUS_LVs, binds)
-coreExprToStg env (CoVar var)
- = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
+coreExprToStg env (Var var)
+ = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
-coreExprToStg env (CoCon con types args)
- = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
+coreExprToStg env (Con con types args)
+ = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) ->
+ returnUs (StgCon spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
where
spec_con = mkSpecialisedCon con types
-coreExprToStg env (CoPrim op tys args)
- = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
+coreExprToStg env (Prim op tys args)
+ = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) ->
+ returnUs (StgPrim op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-coreExprToStg env expr@(CoLam binders body)
- = coreExprToStg env body `thenSUs` \ (stg_body, binds) ->
- newStgVar (typeOfCoreExpr expr) `thenSUs` \ var ->
- returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre
- stgArgOcc
- bOGUS_FVs
- ReEntrant -- binders is non-empty
- binders
- stg_body))
- (StgApp (StgVarAtom var) [] bOGUS_LVs),
- binds)
+coreExprToStg env expr@(Lam _ _)
+ = coreExprToStg env body `thenUs` \ (stg_body, binds) ->
+ newStgVar (coreExprType expr) `thenUs` \ var ->
+ returnUs
+ (StgLet (StgNonRec var (StgRhsClosure noCostCentre
+ stgArgOcc
+ bOGUS_FVs
+ ReEntrant -- binders is non-empty
+ binders
+ stg_body))
+ (StgApp (StgVarArg var) [] bOGUS_LVs),
+ binds)
+ where
+ (binders,body) = collect expr
+
+ -- Collect lambda-bindings, discarding type abstractions and applications
+ collect (Lam x e) = (x:binders, body) where (binders,body) = collect e
+ collect (CoTyLam _ e) = collect e
+ collect (CoTyApp e _) = collect e
+ collect body = ([], body)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-coreExprToStg env expr@(CoApp _ _)
+coreExprToStg env expr@(App _ _)
= -- Deal with the arguments
- mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) ->
+ mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_args, arg_binds) ->
-- Now deal with the function
- case fun of
- CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
+ case fun of
+ Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
unionManyBags arg_binds)
other -> -- A non-variable applied to things; better let-bind it.
- newStgVar (typeOfCoreExpr fun) `thenSUs` \ fun_id ->
- coreExprToStg env fun `thenSUs` \ (stg_fun, fun_binds) ->
+ newStgVar (coreExprType fun) `thenUs` \ fun_id ->
+ coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) ->
let
fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc
[]
stg_fun
in
- returnSUs (StgLet (StgNonRec fun_id fun_rhs)
- (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs),
- unionManyBags arg_binds `unionBags`
+ returnUs (StgLet (StgNonRec fun_id fun_rhs)
+ (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
+ unionManyBags arg_binds `unionBags`
fun_binds)
where
(fun,args) = collect_args expr []
- -- Collect arguments, discarding type applications
- collect_args (CoApp fun arg) args = collect_args fun (arg:args)
- collect_args (CoTyApp e t) args = collect_args e args
+ -- Collect arguments, discarding type abstractions and applications
+ collect_args (App fun arg) args = collect_args fun (arg:args)
+ collect_args (CoTyLam _ e) args = collect_args e args
+ collect_args (CoTyApp e _) args = collect_args e args
collect_args fun args = (fun, args)
\end{code}
\begin{code}
-coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts)
+coreExprToStg env (Case discrim@(Prim op tys args) alts)
| funnyParallelOp op =
- getSUnique `thenSUs` \ uniq ->
- coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
- alts_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (
+ getUnique `thenUs` \ uniq ->
+ coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
+ alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
+ returnUs (
StgCase stg_discrim
bOGUS_LVs
bOGUS_LVs
funnyParallelOp ForkOp = True
funnyParallelOp _ = False
- discrim_ty = typeOfCoreExpr discrim
+ discrim_ty = coreExprType discrim
- alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs))
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- let
- stg_deflt = StgBindDefault binder False stg_rhs
- in
- returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
+ alts_to_stg (PrimAlts _ (BindDefault binder rhs))
+ = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
+ let
+ stg_deflt = StgBindDefault binder False stg_rhs
+ in
+ returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
-- OK, back to real life...
-coreExprToStg env (CoCase discrim alts)
- = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
- alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) ->
- getSUnique `thenSUs` \ uniq ->
- returnSUs (
+coreExprToStg env (Case discrim alts)
+ = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
+ alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) ->
+ getUnique `thenUs` \ uniq ->
+ returnUs (
StgCase stg_discrim
bOGUS_LVs
bOGUS_LVs
discrim_binds `unionBags` alts_binds
)
where
- discrim_ty = typeOfCoreExpr discrim
- (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty
+ discrim_ty = coreExprType discrim
+ (_, discrim_ty_args, _) = getAppDataTyCon discrim_ty
- alts_to_stg discrim (CoAlgAlts alts deflt)
- = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) ->
- mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
+ alts_to_stg discrim (AlgAlts alts deflt)
+ = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) ->
+ mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
+ returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
deflt_binds `unionBags` unionManyBags alts_binds)
where
boxed_alt_to_stg (con, bs, rhs)
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
+ = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
+ returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
rhs_binds)
where
spec_con = mkSpecialisedCon con discrim_ty_args
- alts_to_stg discrim (CoPrimAlts alts deflt)
- = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) ->
- mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
+ alts_to_stg discrim (PrimAlts alts deflt)
+ = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) ->
+ mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
+ returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
deflt_binds `unionBags` unionManyBags alts_binds)
where
unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs ((lit, stg_rhs), rhs_binds)
-
-#ifdef DPH
- alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt)
- = default_to_stg deflt `thenSUs` \ stg_deflt ->
- mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts ->
- returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt)
- where
- boxed_alt_to_stg (con, rhs)
- = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
- returnSUs (con, stg_rhs)
-
- alts_to_stg (CoParPrimAlts tycon ctxt alts deflt)
- = default_to_stg deflt `thenSUs` \ stg_deflt ->
- mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts ->
- returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt)
- where
- unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
- returnSUs (lit, stg_rhs)
-#endif {- Data Parallel Haskell -}
+ = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
+ returnUs ((lit, stg_rhs), rhs_binds)
- default_to_stg discrim CoNoDefault
- = returnSUs (StgNoDefault, emptyBag)
+ default_to_stg discrim NoDefault
+ = returnUs (StgNoDefault, emptyBag)
- default_to_stg discrim (CoBindDefault binder rhs)
- = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
+ default_to_stg discrim (BindDefault binder rhs)
+ = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
+ returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
rhs_binds)
where
--
- -- We convert case x of {...; x' -> ...x'...}
+ -- We convert case x of {...; x' -> ...x'...}
-- to
-- case x of {...; _ -> ...x... }
--
-- default binder to the scrutinee.
--
new_env = case discrim of
- CoVar v -> addOneToIdEnv env binder (stgLookup env v)
+ Var v -> addOneToIdEnv env binder (stgLookup env v)
other -> env
\end{code}
%************************************************************************
\begin{code}
-coreExprToStg env (CoLet bind body)
- = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds1) ->
- coreExprToStg new_env body `thenSUs` \ (stg_body, float_binds2) ->
- returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
+coreExprToStg env (Let bind body)
+ = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) ->
+ coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) ->
+ returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
\end{code}
Covert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
-coreExprToStg env (CoSCC cc expr)
- = coreExprToStg env expr `thenSUs` \ (stg_expr, binds) ->
- returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds)
+coreExprToStg env (SCC cc expr)
+ = coreExprToStg env expr `thenUs` \ (stg_expr, binds) ->
+ returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
\end{code}
-%************************************************************************
-%* *
-\subsubsection[coreToStg-dataParallel]{Data Parallel expressions}
-%* *
-%************************************************************************
-\begin{code}
-#ifdef DPH
-coreExprToStg env (_, AnnCoParCon con ctxt types args)
- = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (mkStgLets (catMaybes stg_binds)
- (StgParConApp con ctxt stg_atoms bOGUS_LVs))
-
-coreExprToStg env (_,AnnCoParComm ctxt expr comm)
- = coreExprToStg env expr `thenSUs` \ stg_expr ->
- annComm_to_stg comm `thenSUs` \ (stg_comm,stg_binds) ->
- returnSUs (mkStgLets (catMaybes stg_binds)
- (StgParComm ctxt stg_expr stg_comm))
- ))
- where
- annComm_to_stg (AnnCoParSend args)
- = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgParSend stg_atoms,stg_binds)
-
- annComm_to_stg (AnnCoParFetch args)
- = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgParFetch stg_atoms,stg_binds)
-
- annComm_to_stg (AnnCoToPodized)
- = returnSUs (StgToPodized,[])
- annComm_to_stg (AnnCoFromPodized)
- = returnSUs (StgFromPodized,[])
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DEBUG
-coreExprToStg env other = panic "coreExprToStg: it really failed here"
-#endif
-\end{code}
%************************************************************************
%* *
Invent a fresh @Id@:
\begin{code}
-newStgVar :: UniType -> SUniqSM Id
+newStgVar :: Type -> UniqSM Id
newStgVar ty
- = getSUnique `thenSUs` \ uniq ->
- returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
+ = getUnique `thenUs` \ uniq ->
+ returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
\end{code}
\begin{code}
-mkStgLets :: [PlainStgBinding]
- -> PlainStgExpr -- body of let
- -> PlainStgExpr
+mkStgLets :: [StgBinding]
+ -> StgExpr -- body of let
+ -> StgExpr
mkStgLets binds body = foldr StgLet body binds
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgFuns where
-import Id(Id)
-import StgSyn(StgRhs)
-mapStgBindeesRhs :: (Id -> Id) -> StgRhs Id Id -> StgRhs Id Id
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgLint where
-import CmdLineOpts(GlobalSwitch)
-import Id(Id)
-import Pretty(PprStyle)
-import StgSyn(PlainStgBinding(..), StgBinding, StgRhs)
-data Id
-data PprStyle
-type PlainStgBinding = StgBinding Id Id
-data StgBinding a b
-lintStgBindings :: PprStyle -> [Char] -> [StgBinding Id Id] -> [StgBinding Id Id]
-
\begin{code}
#include "HsVersions.h"
-module StgLint (
- lintStgBindings,
-
- PprStyle, StgBinding, PlainStgBinding(..), Id
- ) where
+module StgLint ( lintStgBindings ) where
-IMPORT_Trace
-
-import AbsPrel ( typeOfPrimOp, mkFunTy, PrimOp(..), PrimKind
+import PrelInfo ( primOpType, mkFunTy, PrimOp(..), PrimRep
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType
+import Type
import Bag
-import BasicLit ( typeOfBasicLit, BasicLit )
-import Id ( getIdUniType, isNullaryDataCon, isDataCon,
- isBottomingId,
- getInstantiatedDataConSig, Id
- IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
+import Literal ( literalType, Literal )
+import Id ( idType, isDataCon,
+ getInstantiatedDataConSig
)
import Maybes
import Outputable
infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
\end{code}
-Checks for
+Checks for
(a) *some* type errors
(b) locally-defined variables used but not defined
@lintStgBindings@ is the top-level interface function.
\begin{code}
-lintStgBindings :: PprStyle -> String -> [PlainStgBinding] -> [PlainStgBinding]
+lintStgBindings :: PprStyle -> String -> [StgBinding] -> [StgBinding]
lintStgBindings sty whodunnit binds
= BSCC("StgLint")
ppStr "*** End of Offense ***"])
ESCC
where
- lint_binds :: [PlainStgBinding] -> LintM ()
+ lint_binds :: [StgBinding] -> LintM ()
lint_binds [] = returnL ()
- lint_binds (bind:binds)
+ lint_binds (bind:binds)
= lintStgBinds bind `thenL` \ binders ->
addInScopeVars binders (
lint_binds binds
\begin{code}
-lintStgAtom :: PlainStgAtom -> LintM (Maybe UniType)
+lintStgArg :: StgArg -> LintM (Maybe Type)
-lintStgAtom (StgLitAtom lit) = returnL (Just (typeOfBasicLit lit))
-lintStgAtom a@(StgVarAtom v)
+lintStgArg (StgLitArg lit) = returnL (Just (literalType lit))
+lintStgArg a@(StgVarArg v)
= checkInScope v `thenL_`
- returnL (Just (getIdUniType v))
+ returnL (Just (idType v))
\end{code}
\begin{code}
-lintStgBinds :: PlainStgBinding -> LintM [Id] -- Returns the binders
+lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
lintStgBinds (StgNonRec binder rhs)
= lint_binds_help (binder,rhs) `thenL_`
returnL [binder]
-lintStgBinds (StgRec pairs)
+lintStgBinds (StgRec pairs)
= addInScopeVars binders (
mapL lint_binds_help pairs `thenL_`
returnL binders
-- Check match to RHS type
(case maybe_rhs_ty of
Nothing -> returnL ()
- Just rhs_ty -> checkTys (getIdUniType binder)
- rhs_ty
+ Just rhs_ty -> checkTys (idType binder)
+ rhs_ty
(mkRhsMsg binder rhs_ty)
- ) `thenL_`
+ ) `thenL_`
returnL ()
)
\end{code}
\begin{code}
-lintStgRhs :: PlainStgRhs -> LintM (Maybe UniType)
+lintStgRhs :: StgRhs -> LintM (Maybe Type)
lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) (
addInScopeVars binders (
lintStgExpr expr `thenMaybeL` \ body_ty ->
- returnL (Just (foldr (mkFunTy . getIdUniType) body_ty binders))
+ returnL (Just (foldr (mkFunTy . idType) body_ty binders))
))
lintStgRhs (StgRhsCon _ con args)
- = mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys ->
+ = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
case maybe_arg_tys of
Nothing -> returnL Nothing
Just arg_tys -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
where
- con_ty = getIdUniType con
+ con_ty = idType con
\end{code}
\begin{code}
-lintStgExpr :: PlainStgExpr -> LintM (Maybe UniType) -- Nothing if error found
+lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found
lintStgExpr e@(StgApp fun args _)
- = lintStgAtom fun `thenMaybeL` \ fun_ty ->
- mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys ->
+ = lintStgArg fun `thenMaybeL` \ fun_ty ->
+ mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
case maybe_arg_tys of
Nothing -> returnL Nothing
Just arg_tys -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
-lintStgExpr e@(StgConApp con args _)
- = mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys ->
+lintStgExpr e@(StgCon con args _)
+ = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
case maybe_arg_tys of
Nothing -> returnL Nothing
Just arg_tys -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
where
- con_ty = getIdUniType con
+ con_ty = idType con
-lintStgExpr e@(StgPrimApp op args _)
- = mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys ->
+lintStgExpr e@(StgPrim op args _)
+ = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
case maybe_arg_tys of
Nothing -> returnL Nothing
Just arg_tys -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
where
- op_ty = typeOfPrimOp op
+ op_ty = primOpType op
-lintStgExpr (StgLet binds body)
+lintStgExpr (StgLet binds body)
= lintStgBinds binds `thenL` \ binders ->
addLoc (BodyOfLetRec binders) (
addInScopeVars binders (
lintStgExpr body
))
-lintStgExpr (StgLetNoEscape _ _ binds body)
+lintStgExpr (StgLetNoEscape _ _ binds body)
= lintStgBinds binds `thenL` \ binders ->
addLoc (BodyOfLetRec binders) (
addInScopeVars binders (
= lintStgExpr scrut `thenMaybeL` \ _ ->
-- Check that it is a data type
- case getUniDataTyCon_maybe scrut_ty of
+ case maybeDataTyCon scrut_ty of
Nothing -> addErrL (mkCaseDataConMsg e) `thenL_`
returnL Nothing
Just (tycon, _, _)
\end{code}
\begin{code}
-lintStgAlts :: PlainStgCaseAlternatives
- -> UniType -- Type of scrutinee
+lintStgAlts :: StgCaseAlts
+ -> Type -- Type of scrutinee
-> TyCon -- TyCon pinned on the case
- -> LintM (Maybe UniType) -- Type of alternatives
+ -> LintM (Maybe Type) -- Type of alternatives
lintStgAlts alts scrut_ty case_tycon
= (case alts of
- StgAlgAlts _ alg_alts deflt ->
+ StgAlgAlts _ alg_alts deflt ->
chk_non_abstract_type case_tycon `thenL_`
mapL (lintAlgAlt scrut_ty) alg_alts `thenL` \ maybe_alt_tys ->
lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
returnL (maybe_deflt_ty : maybe_alt_tys)
- StgPrimAlts _ prim_alts deflt ->
+ StgPrimAlts _ prim_alts deflt ->
mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
returnL (maybe_deflt_ty : maybe_alt_tys)
Just _ -> returnL () -- that's cool
lintAlgAlt scrut_ty (con, args, _, rhs)
- = (case getUniDataTyCon_maybe scrut_ty of
- Nothing ->
+ = (case maybeDataTyCon scrut_ty of
+ Nothing ->
addErrL (mkAlgAltMsg1 scrut_ty)
Just (tycon, tys_applied, cons) ->
let
(_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
in
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
- checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
+ checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
`thenL_`
mapL check (arg_tys `zipEqual` args) `thenL_`
returnL ()
lintStgExpr rhs
)
where
- check (ty, arg) = checkTys ty (getIdUniType arg) (mkAlgAltMsg4 ty arg)
+ check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
-- elem: yes, the elem-list here can sometimes be long-ish,
-- but as it's use-once, probably not worth doing anything different
elem x (y:ys) = x==y || elem x ys
lintPrimAlt scrut_ty alt@(lit,rhs)
- = checkTys (typeOfBasicLit lit) scrut_ty (mkPrimAltMsg alt) `thenL_`
+ = checkTys (literalType lit) scrut_ty (mkPrimAltMsg alt) `thenL_`
lintStgExpr rhs
-
+
lintDeflt StgNoDefault scrut_ty = returnL Nothing
-lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
- = checkTys (getIdUniType binder) scrut_ty (mkDefltMsg deflt) `thenL_`
+lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
+ = checkTys (idType binder) scrut_ty (mkDefltMsg deflt) `thenL_`
addInScopeVars [binder] (
lintStgExpr rhs
)
= ppInterleave ppComma (map pp_binder bs)
where
pp_binder b
- = ppCat [ppr sty b, ppStr "::", ppr sty (getIdUniType b)]
+ = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
\end{code}
\begin{code}
thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL m k loc scope errs
- = case m loc scope errs of
+ = case m loc scope errs of
(r, errs') -> k r loc scope errs'
thenL_ :: LintM a -> LintM b -> LintM b
thenL_ m k loc scope errs
- = case m loc scope errs of
+ = case m loc scope errs of
(_, errs') -> k loc scope errs'
thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
\end{code}
\begin{code}
-checkFunApp :: UniType -- The function type
- -> [UniType] -- The arg type(s)
+checkFunApp :: Type -- The function type
+ -> [Type] -- The arg type(s)
-> ErrMsg -- Error messgae
- -> LintM (Maybe UniType) -- The result type
+ -> LintM (Maybe Type) -- The result type
checkFunApp fun_ty arg_tys msg loc scope errs
= cfa res_ty expected_arg_tys arg_tys
cfa res_ty [] arg_tys -- Expected arg tys ran out first;
-- first see if res_ty is a tyvar template;
- -- otherwise, maybe res_ty is a
+ -- otherwise, maybe res_ty is a
-- dictionary type which is actually a function?
| isTyVarTemplateTy res_ty
= (Just res_ty, errs)
else
((), errs)
-checkTys :: UniType -> UniType -> ErrMsg -> LintM ()
+checkTys :: Type -> Type -> ErrMsg -> LintM ()
checkTys ty1 ty2 msg loc scope errs
= case (sleazy_cmp_ty ty1 ty2) of
EQ_ -> ((), errs)
\end{code}
\begin{code}
-mkCaseAltMsg :: PlainStgCaseAlternatives -> ErrMsg
+mkCaseAltMsg :: StgCaseAlts -> ErrMsg
mkCaseAltMsg alts sty
= ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
-- LATER: (ppr sty alts)
(panic "mkCaseAltMsg")
-mkCaseDataConMsg :: PlainStgExpr -> ErrMsg
+mkCaseDataConMsg :: StgExpr -> ErrMsg
mkCaseDataConMsg expr sty
= ppAbove (ppStr "A case scrutinee not a type-constructor type:")
(pp_expr sty expr)
= ppAbove (ppStr "An algebraic case on an abstract type:")
(ppr sty tycon)
-mkDefltMsg :: PlainStgCaseDefault -> ErrMsg
+mkDefltMsg :: StgCaseDefault -> ErrMsg
mkDefltMsg deflt sty
= ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
--LATER: (ppr sty deflt)
(panic "mkDefltMsg")
-mkFunAppMsg :: UniType -> [UniType] -> PlainStgExpr -> ErrMsg
+mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg
mkFunAppMsg fun_ty arg_tys expr sty
= ppAboves [ppStr "In a function application, function type doesn't match arg types:",
ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
-mkRhsConMsg :: UniType -> [UniType] -> ErrMsg
+mkRhsConMsg :: Type -> [Type] -> ErrMsg
mkRhsConMsg fun_ty arg_tys sty
= ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:",
ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty),
ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))]
-mkUnappTyMsg :: Id -> UniType -> ErrMsg
+mkUnappTyMsg :: Id -> Type -> ErrMsg
mkUnappTyMsg var ty sty
= ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
ppBeside (ppStr "Var: ") (ppr sty var),
ppBeside (ppStr "Its type: ") (ppr sty ty)]
-mkAlgAltMsg1 :: UniType -> ErrMsg
+mkAlgAltMsg1 :: Type -> ErrMsg
mkAlgAltMsg1 ty sty
= ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
(ppr sty ty)
-mkAlgAltMsg2 :: UniType -> Id -> ErrMsg
+mkAlgAltMsg2 :: Type -> Id -> ErrMsg
mkAlgAltMsg2 ty con sty
= ppAboves [
ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
ppr sty alts
]
-mkAlgAltMsg4 :: UniType -> Id -> ErrMsg
+mkAlgAltMsg4 :: Type -> Id -> ErrMsg
mkAlgAltMsg4 ty arg sty
= ppAboves [
ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
ppr sty arg
]
-mkPrimAltMsg :: (BasicLit, PlainStgExpr) -> ErrMsg
+mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg
mkPrimAltMsg alt sty
= ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
(ppr sty alt)
-mkRhsMsg :: Id -> UniType -> ErrMsg
+mkRhsMsg :: Id -> Type -> ErrMsg
mkRhsMsg binder ty sty
- = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
+ = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
ppr sty binder],
- ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)],
+ ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
ppCat [ppStr "Rhs type:", ppr sty ty]
]
-pp_expr :: PprStyle -> PlainStgExpr -> Pretty
+pp_expr :: PprStyle -> StgExpr -> Pretty
pp_expr sty expr = ppr sty expr
sleazy_cmp_ty ty1 ty2
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StgSyn where
-import Bag(Bag)
-import BasicLit(BasicLit)
-import CharSeq(CSeq)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import CostCentre(CostCentre)
-import HsBinds(Binds)
-import HsExpr(Expr)
-import HsMatches(GRHS, GRHSsAndBinds)
-import HsPat(InPat)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(IdInfo)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp)
-import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import TyVarEnv(TyVarEnv(..))
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import UniqFM(UniqFM)
-import UniqSet(UniqSet(..))
-import Unique(Unique)
-class NamedThing a where
- getExportFlag :: a -> ExportFlag
- isLocallyDefined :: a -> Bool
- getOrigName :: a -> (_PackedString, _PackedString)
- getOccurrenceName :: a -> _PackedString
- getInformingModules :: a -> [_PackedString]
- getSrcLoc :: a -> SrcLoc
- getTheUnique :: a -> Unique
- hasType :: a -> Bool
- getType :: a -> UniType
- fromPreludeCore :: a -> Bool
-class Outputable a where
- ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data Bag a
-data BasicLit
-data Class
-data ClassOp
-data CostCentre
-data Binds a b
-data Expr a b
-data GRHS a b
-data GRHSsAndBinds a b
-data InPat a
-data Id
-type IdEnv a = UniqFM a
-data IdInfo
-data Labda a
-data Name
-data FullName
-data ShortName
-data ExportFlag
-type PlainStgAtom = StgAtom Id
-type PlainStgBinding = StgBinding Id Id
-type PlainStgCaseAlternatives = StgCaseAlternatives Id Id
-type PlainStgCaseDefault = StgCaseDefault Id Id
-type PlainStgExpr = StgExpr Id Id
-type PlainStgLiveVars = UniqFM Id
-type PlainStgProgram = [StgBinding Id Id]
-type PlainStgRhs = StgRhs Id Id
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data PrimKind
-data PrimOp
-data SrcLoc
-data StgAtom a = StgVarAtom a | StgLitAtom BasicLit
-data StgBinderInfo = NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool
-data StgBinding a b = StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)]
-data StgCaseAlternatives a b = StgAlgAlts UniType [(Id, [a], [Bool], StgExpr a b)] (StgCaseDefault a b) | StgPrimAlts UniType [(BasicLit, StgExpr a b)] (StgCaseDefault a b)
-data StgCaseDefault a b = StgNoDefault | StgBindDefault a Bool (StgExpr a b)
-data StgExpr a b = StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b)
-type StgLiveVars a = UniqFM a
-data StgRhs a b = StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b]
-data TyCon
-data TyVar
-data TyVarTemplate
-type TyVarEnv a = UniqFM a
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-data UpdateFlag = ReEntrant | Updatable | SingleEntry
-collectExportedStgBinders :: [StgBinding Id Id] -> [Id]
-combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
-getAtomKind :: StgAtom Id -> PrimKind
-isLitLitStgAtom :: StgAtom a -> Bool
-pprPlainStgBinding :: PprStyle -> StgBinding Id Id -> Int -> Bool -> PrettyRep
-stgArgOcc :: StgBinderInfo
-stgArity :: StgRhs Id Id -> Int
-stgFakeFunAppOcc :: StgBinderInfo
-stgNoUpdHeapOcc :: StgBinderInfo
-stgNormalOcc :: StgBinderInfo
-stgStdHeapOcc :: StgBinderInfo
-stgUnsatOcc :: StgBinderInfo
-instance Eq BasicLit
-instance Eq Class
-instance Eq ClassOp
-instance Eq Id
-instance Eq PrimKind
-instance Eq PrimOp
-instance Eq TyCon
-instance Eq TyVar
-instance Eq TyVarTemplate
-instance Eq UniType
-instance Eq Unique
-instance Ord BasicLit
-instance Ord Class
-instance Ord ClassOp
-instance Ord Id
-instance Ord PrimKind
-instance Ord TyCon
-instance Ord TyVar
-instance Ord TyVarTemplate
-instance Ord Unique
-instance NamedThing Class
-instance NamedThing a => NamedThing (InPat a)
-instance NamedThing Id
-instance NamedThing FullName
-instance NamedThing ShortName
-instance NamedThing TyCon
-instance NamedThing TyVar
-instance NamedThing TyVarTemplate
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable BasicLit
-instance Outputable Bool
-instance Outputable Class
-instance Outputable ClassOp
-instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Binds a b)
-instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Expr a b)
-instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHS a b)
-instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHSsAndBinds a b)
-instance Outputable a => Outputable (InPat a)
-instance Outputable Id
-instance Outputable FullName
-instance Outputable ShortName
-instance Outputable PrimKind
-instance Outputable PrimOp
-instance Outputable a => Outputable (StgAtom a)
-instance (Outputable a, Outputable b, Ord b) => Outputable (StgBinding a b)
-instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b)
-instance (Outputable a, Outputable b, Ord b) => Outputable (StgRhs a b)
-instance Outputable UpdateFlag
-instance Outputable TyCon
-instance Outputable TyVar
-instance Outputable TyVarTemplate
-instance Outputable UniType
-instance Outputable a => Outputable [a]
-instance Text Unique
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
#include "HsVersions.h"
module StgSyn (
- StgAtom(..),
- StgLiveVars(..),
+ GenStgArg(..),
+ GenStgLiveVars(..),
- StgBinding(..), StgExpr(..), StgRhs(..),
- StgCaseAlternatives(..), StgCaseDefault(..),
-#ifdef DPH
- StgParCommunicate(..),
-#endif {- Data Parallel Haskell -}
+ GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
+ GenStgCaseAlts(..), GenStgCaseDefault(..),
UpdateFlag(..),
combineStgBinderInfo,
-- a set of synonyms for the most common (only :-) parameterisation
- PlainStgAtom(..), PlainStgLiveVars(..), PlainStgProgram(..),
- PlainStgBinding(..), PlainStgExpr(..), PlainStgRhs(..),
- PlainStgCaseAlternatives(..), PlainStgCaseDefault(..),
+ StgArg(..), StgLiveVars(..),
+ StgBinding(..), StgExpr(..), StgRhs(..),
+ StgCaseAlts(..), StgCaseDefault(..),
pprPlainStgBinding,
---UNUSED: fvsFromAtoms,
- getAtomKind,
- isLitLitStgAtom,
+ getArgPrimRep,
+ isLitLitArg,
stgArity,
- collectExportedStgBinders,
+ collectExportedStgBinders
-- and to make the interface self-sufficient...
- Outputable(..), NamedThing(..), Pretty(..),
- Unique, ExportFlag, SrcLoc, PprStyle, PrettyRep,
-
- BasicLit, Class, ClassOp,
-
- Binds, Expr, GRHS, GRHSsAndBinds, InPat,
-
- Id, IdInfo, Maybe, Name, FullName, ShortName,
- PrimKind, PrimOp, CostCentre, TyCon, TyVar,
- UniqSet(..), UniqFM, Bag,
- TyVarTemplate, UniType, TauType(..),
- ThetaType(..), SigmaType(..),
- TyVarEnv(..), IdEnv(..)
-
- IF_ATTACK_PRAGMAS(COMMA isLitLitLit)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
) where
-import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..),
- PrimOp, PrimKind
+import Ubiq{-uitous-}
+
+{-
+import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..),
+ PrimOp, PrimRep
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsSyn ( Binds, Expr, GRHS, GRHSsAndBinds, InPat )
-import AbsUniType
-import BasicLit ( typeOfBasicLit, kindOfBasicLit, isLitLitLit,
- BasicLit(..) -- (..) for pragmas
+import HsSyn ( HsBinds, HsExpr, GRHS, GRHSsAndBinds, InPat )
+import Type
+import Literal ( literalPrimRep, isLitLitLit,
+ Literal(..) -- (..) for pragmas
)
-import Id ( getIdUniType, getIdKind, toplevelishId,
+import Id ( idType, getIdPrimRep, toplevelishId,
isTopLevId, Id, IdInfo
)
import Maybes ( Maybe(..), catMaybes )
import Outputable
import Pretty
-import PrimKind ( PrimKind )
import CostCentre ( showCostCentre, CostCentre )
import UniqSet
-import Unique
import Util
+-}
\end{code}
%************************************************************************
%* *
-\subsection[StgBinding]{@StgBinding@}
+\subsection{@GenStgBinding@}
%* *
%************************************************************************
As usual, expressions are interesting; other things are boring. Here
-are the boring things [except note the @StgRhs@], parameterised with
-respect to binder and bindee information (just as in @CoreSyntax@):
-\begin{code}
-data StgBinding binder bindee
- = StgNonRec binder (StgRhs binder bindee)
- | StgRec [(binder, StgRhs binder bindee)]
-\end{code}
+are the boring things [except note the @GenStgRhs@], parameterised
+with respect to binder and occurrence information (just as in
+@CoreSyn@):
-An @StgProgram@ is just a list of @StgBindings@; the
-properties/restrictions-on this list are the same as for a
-@CoreProgram@ (a list of @CoreBindings@).
\begin{code}
---type StgProgram binder bindee = [StgBinding binder bindee]
+data GenStgBinding bndr occ
+ = StgNonRec bndr (GenStgRhs bndr occ)
+ | StgRec [(bndr, GenStgRhs bndr occ)]
\end{code}
%************************************************************************
%* *
-\subsection[StgAtom]{@StgAtom@}
+\subsection{@GenStgArg@}
%* *
%************************************************************************
\begin{code}
-data StgAtom bindee
- = StgVarAtom bindee
- | StgLitAtom BasicLit
+data GenStgArg occ
+ = StgVarArg occ
+ | StgLitArg Literal
\end{code}
\begin{code}
-getAtomKind (StgVarAtom local) = getIdKind local
-getAtomKind (StgLitAtom lit) = kindOfBasicLit lit
+getArgPrimRep (StgVarArg local) = getIdPrimRep local
+getArgPrimRep (StgLitArg lit) = literalPrimRep lit
-{- UNUSED happily
-fvsFromAtoms :: [PlainStgAtom] -> (UniqSet Id) -- ToDo: this looks like a HACK to me (WDP)
-fvsFromAtoms as = mkUniqSet [ id | (StgVarAtom id) <- as, not (toplevelishId id) ]
--}
-
-isLitLitStgAtom (StgLitAtom x) = isLitLitLit x
-isLitLitStgAtom _ = False
+isLitLitArg (StgLitArg x) = isLitLitLit x
+isLitLitArg _ = False
\end{code}
%************************************************************************
%* *
-\subsection[StgExpr]{STG expressions}
+\subsection{STG expressions}
%* *
%************************************************************************
-The @StgExpr@ data type is parameterised on binder and bindee info, as
-before.
+The @GenStgExpr@ data type is parameterised on binder and occurrence
+info, as before.
%************************************************************************
%* *
-\subsubsection[StgExpr-application]{@StgExpr@ application}
+\subsubsection{@GenStgExpr@ application}
%* *
%************************************************************************
There is no constructor for a lone variable; it would appear as
@StgApp var [] _@.
\begin{code}
-type StgLiveVars bindee = UniqSet bindee
+type GenStgLiveVars occ = UniqSet occ
-data StgExpr binder bindee
- = StgApp
- (StgAtom bindee) -- function
- [StgAtom bindee] -- arguments
- (StgLiveVars bindee) -- Live vars in continuation; ie not
+data GenStgExpr bndr occ
+ = StgApp
+ (GenStgArg occ) -- function
+ [GenStgArg occ] -- arguments
+ (GenStgLiveVars occ) -- Live vars in continuation; ie not
-- including the function and args
-- NB: a literal is: StgApp <lit-atom> [] ...
%************************************************************************
%* *
-\subsubsection[StgExpr-apps]{@StgConApp@ and @StgPrimApp@---saturated applications}
+\subsubsection{@StgCon@ and @StgPrim@---saturated applications}
%* *
%************************************************************************
There are two specialised forms of application, for
constructors and primitives.
\begin{code}
- | StgConApp -- always saturated
+ | StgCon -- always saturated
Id -- data constructor
- [StgAtom bindee]
- (StgLiveVars bindee) -- Live vars in continuation; ie not
+ [GenStgArg occ]
+ (GenStgLiveVars occ) -- Live vars in continuation; ie not
-- including the constr and args
- | StgPrimApp -- always saturated
+ | StgPrim -- always saturated
PrimOp
- [StgAtom bindee]
- (StgLiveVars bindee) -- Live vars in continuation; ie not
+ [GenStgArg occ]
+ (GenStgLiveVars occ) -- Live vars in continuation; ie not
-- including the op and args
\end{code}
These forms are to do ``inline versions,'' as it were.
%************************************************************************
%* *
-\subsubsection[StgExpr-case]{@StgExpr@: case-expressions}
+\subsubsection{@GenStgExpr@: case-expressions}
%* *
%************************************************************************
This has the same boxed/unboxed business as Core case expressions.
\begin{code}
| StgCase
- (StgExpr binder bindee)
+ (GenStgExpr bndr occ)
-- the thing to examine
- (StgLiveVars bindee) -- Live vars of whole case
+ (GenStgLiveVars occ) -- Live vars of whole case
-- expression; i.e., those which mustn't be
-- overwritten
- (StgLiveVars bindee) -- Live vars of RHSs;
+ (GenStgLiveVars occ) -- Live vars of RHSs;
-- i.e., those which must be saved before eval.
--
-- note that an alt's constructor's
-- variable to hold the tag of a primop with
-- algebraic result
- (StgCaseAlternatives binder bindee)
+ (GenStgCaseAlts bndr occ)
\end{code}
%************************************************************************
%* *
-\subsubsection[StgExpr-lets]{@StgExpr@: @let(rec)@-expressions}
+\subsubsection{@GenStgExpr@: @let(rec)@-expressions}
%* *
%************************************************************************
\item
We may eventually want:
\begin{verbatim}
-let-literal x = BasicLit
+let-literal x = Literal
in e
\end{verbatim}
And so the code for let(rec)-things:
\begin{code}
| StgLet
- (StgBinding binder bindee) -- right hand sides (see below)
- (StgExpr binder bindee) -- body
+ (GenStgBinding bndr occ) -- right hand sides (see below)
+ (GenStgExpr bndr occ) -- body
| StgLetNoEscape -- remember: ``advanced stuff''
- (StgLiveVars bindee) -- Live in the whole let-expression
+ (GenStgLiveVars occ) -- Live in the whole let-expression
-- Mustn't overwrite these stack slots
-- *Doesn't* include binders of the let(rec).
- (StgLiveVars bindee) -- Live in the right hand sides (only)
+ (GenStgLiveVars occ) -- Live in the right hand sides (only)
-- These are the ones which must be saved on
-- the stack if they aren't there already
-- *Does* include binders of the let(rec) if recursive.
- (StgBinding binder bindee) -- right hand sides (see below)
- (StgExpr binder bindee) -- body
+ (GenStgBinding bndr occ) -- right hand sides (see below)
+ (GenStgExpr bndr occ) -- body
\end{code}
%************************************************************************
%* *
-\subsubsection[StgExpr-scc]{@StgExpr@: @scc@ expressions}
+\subsubsection{@GenStgExpr@: @scc@ expressions}
%* *
%************************************************************************
\begin{code}
| StgSCC
- UniType -- the type of the body
+ Type -- the type of the body
CostCentre -- label of SCC expression
- (StgExpr binder bindee) -- scc expression
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[DataParallel]{Data parallel extensions to STG syntax}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef DPH
- | StgParConApp -- saturated parallel constructor
- Id
- Int -- What parallel context
- [StgAtom bindee]
- (StgLiveVars bindee)
-
- | StgParComm
- Int
- (StgExpr binder bindee) -- The thing we are communicating
- (StgParCommunicate binder bindee)
-#endif {- Data Parallel Haskell -}
- -- end of StgExpr
+ (GenStgExpr bndr occ) -- scc expression
+ -- end of GenStgExpr
\end{code}
%************************************************************************
%* *
-\subsection[StgRhs]{STG right-hand sides}
+\subsection{STG right-hand sides}
%* *
%************************************************************************
Here's the rest of the interesting stuff for @StgLet@s; the first
flavour is for closures:
\begin{code}
-data StgRhs binder bindee
+data GenStgRhs bndr occ
= StgRhsClosure
CostCentre -- cost centre to be attached (default is CCC)
StgBinderInfo -- Info about how this binder is used (see below)
- [bindee] -- non-global free vars; a list, rather than
+ [occ] -- non-global free vars; a list, rather than
-- a set, because order is important
UpdateFlag -- ReEntrant | Updatable | SingleEntry
- [binder] -- arguments; if empty, then not a function;
+ [bndr] -- arguments; if empty, then not a function;
-- as above, order is important
- (StgExpr binder bindee) -- body
+ (GenStgExpr bndr occ) -- body
\end{code}
An example may be in order. Consider:
\begin{verbatim}
-- data in heap profiles, and we don't set CCC
-- from static closure.
Id -- constructor
- [StgAtom bindee] -- args
+ [GenStgArg occ] -- args
\end{code}
Here's the @StgBinderInfo@ type, and its combining op:
\begin{code}
-data StgBinderInfo
+data StgBinderInfo
= NoStgBinderInfo
-
| StgBinderInfo
Bool -- At least one occurrence as an argument
Bool -- At least one fake application occurrence, that is
-- an StgApp f args where args is an empty list
-- This is due to the fact that we do not have a
- -- StgVar constructor.
+ -- StgVar constructor.
-- Used by the lambda lifter.
-- True => "at least one unsat app" is True too
stgNoUpdHeapOcc = StgBinderInfo False False False True False
stgNormalOcc = StgBinderInfo False False False False False
-- [Andre] can't think of a good name for the last one.
-stgFakeFunAppOcc = StgBinderInfo False True False False True
+stgFakeFunAppOcc = StgBinderInfo False True False False True
combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
Just like in @CoreSyntax@ (except no type-world stuff).
\begin{code}
-data StgCaseAlternatives binder bindee
- = StgAlgAlts UniType -- so we can find out things about constructor family
+data GenStgCaseAlts bndr occ
+ = StgAlgAlts Type -- so we can find out things about constructor family
[(Id, -- alts: data constructor,
- [binder], -- constructor's parameters,
+ [bndr], -- constructor's parameters,
[Bool], -- "use mask", same length as
-- parameters; a True in a
-- param's position if it is
-- used in the ...
- StgExpr binder bindee)] -- ...right-hand side.
- (StgCaseDefault binder bindee)
- | StgPrimAlts UniType -- so we can find out things about constructor family
- [(BasicLit, -- alts: unboxed literal,
- StgExpr binder bindee)] -- rhs.
- (StgCaseDefault binder bindee)
-#ifdef DPH
- | StgParAlgAlts
- UniType
- Int -- What context we are in
- [binder]
- [(Id,StgExpr binder bindee)]
- (StgCaseDefault binder bindee)
- | StgParPrimAlts UniType
- Int -- What context we are in
- [(BasicLit, -- alts: unboxed literal,
- StgExpr binder bindee)] -- rhs.
- (StgCaseDefault binder bindee)
-#endif {- Data Parallel Haskell -}
-
-data StgCaseDefault binder bindee
+ GenStgExpr bndr occ)] -- ...right-hand side.
+ (GenStgCaseDefault bndr occ)
+ | StgPrimAlts Type -- so we can find out things about constructor family
+ [(Literal, -- alts: unboxed literal,
+ GenStgExpr bndr occ)] -- rhs.
+ (GenStgCaseDefault bndr occ)
+
+data GenStgCaseDefault bndr occ
= StgNoDefault -- small con family: all
-- constructor accounted for
- | StgBindDefault binder -- form: var -> expr
+ | StgBindDefault bndr -- form: var -> expr
Bool -- True <=> var is used in rhs
-- i.e., False <=> "_ -> expr"
- (StgExpr binder bindee)
+ (GenStgExpr bndr occ)
\end{code}
%************************************************************************
%* *
-\subsection[Stg-parComummunicate]{Communication operations}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef DPH
-data StgParCommunicate binder bindee
- = StgParSend
- [StgAtom bindee] -- Sending PODs
-
- | StgParFetch
- [StgAtom bindee] -- Fetching PODs
-
- | StgToPodized -- Convert a POD to the podized form
-
- | StgFromPodized -- Convert a POD from the podized form
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PlainStg]{The Plain STG parameterisation}
+\subsection[Stg]{The Plain STG parameterisation}
%* *
%************************************************************************
This happens to be the only one we use at the moment.
\begin{code}
-type PlainStgProgram = [StgBinding Id Id]
-type PlainStgBinding = StgBinding Id Id
-type PlainStgAtom = StgAtom Id
-type PlainStgLiveVars= UniqSet Id
-type PlainStgExpr = StgExpr Id Id
-type PlainStgRhs = StgRhs Id Id
-type PlainStgCaseAlternatives = StgCaseAlternatives Id Id
-type PlainStgCaseDefault = StgCaseDefault Id Id
+type StgBinding = GenStgBinding Id Id
+type StgArg = GenStgArg Id
+type StgLiveVars = GenStgLiveVars Id
+type StgExpr = GenStgExpr Id Id
+type StgRhs = GenStgRhs Id Id
+type StgCaseAlts = GenStgCaseAlts Id Id
+type StgCaseDefault = GenStgCaseDefault Id Id
\end{code}
%************************************************************************
\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
%* *
%************************************************************************
-
+
This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
-
+
\begin{code}
data UpdateFlag = ReEntrant | Updatable | SingleEntry
-
+
instance Outputable UpdateFlag where
ppr sty u
= ppChar (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
\begin{code}
collectExportedStgBinders
- :: [PlainStgBinding] -- input: PlainStgProgram
+ :: [StgBinding] -- input program
-> [Id] -- exported top-level Ids
collectExportedStgBinders binds
- = exported_from_here [] binds
+ = ex [] binds
where
- exported_from_here es [] = es
+ ex es [] = es
- exported_from_here es ((StgNonRec b _) : binds)
+ ex es ((StgNonRec b _) : binds)
= if not (isExported b) then
- exported_from_here es binds
+ ex es binds
else
- exported_from_here (b:es) binds
+ ex (b:es) binds
- exported_from_here es ((StgRec []) : binds)
- = exported_from_here es binds
+ ex es ((StgRec []) : binds) = ex es binds
- exported_from_here es ((StgRec ((b, rhs) : pairs)) : binds)
- = exported_from_here
- es
- (StgNonRec b rhs : (StgRec pairs : binds))
+ ex es ((StgRec ((b, rhs) : pairs)) : binds)
+ = ex es (StgNonRec b rhs : (StgRec pairs : binds))
-- OK, a total hack; laziness rules
\end{code}
\begin{code}
pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
- PprStyle -> StgBinding bndr bdee -> Pretty
+ PprStyle -> GenStgBinding bndr bdee -> Pretty
-pprStgBinding sty (StgNonRec binder rhs)
- = ppHang (ppCat [ppr sty binder, ppEquals])
+pprStgBinding sty (StgNonRec bndr rhs)
+ = ppHang (ppCat [ppr sty bndr, ppEquals])
4 (ppBeside (ppr sty rhs) ppSemi)
pprStgBinding sty (StgRec pairs)
= ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
(map (ppr_bind sty) pairs))
where
- ppr_bind sty (binder, expr)
- = ppHang (ppCat [ppr sty binder, ppEquals])
+ ppr_bind sty (bndr, expr)
+ = ppHang (ppCat [ppr sty bndr, ppEquals])
4 (ppBeside (ppr sty expr) ppSemi)
-pprPlainStgBinding :: PprStyle -> PlainStgBinding -> Pretty
+pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
pprPlainStgBinding sty b = pprStgBinding sty b
\end{code}
\begin{code}
-instance (Outputable bdee) => Outputable (StgAtom bdee) where
- ppr = pprStgAtom
+instance (Outputable bdee) => Outputable (GenStgArg bdee) where
+ ppr = pprStgArg
instance (Outputable bndr, Outputable bdee, Ord bdee)
- => Outputable (StgBinding bndr bdee) where
+ => Outputable (GenStgBinding bndr bdee) where
ppr = pprStgBinding
instance (Outputable bndr, Outputable bdee, Ord bdee)
- => Outputable (StgExpr bndr bdee) where
+ => Outputable (GenStgExpr bndr bdee) where
ppr = pprStgExpr
-{- OLD:
instance (Outputable bndr, Outputable bdee, Ord bdee)
- => Outputable (StgCaseDefault bndr bdee) where
- ppr sty deflt = panic "ppr:StgCaseDefault"
--}
-
-instance (Outputable bndr, Outputable bdee, Ord bdee)
- => Outputable (StgRhs bndr bdee) where
+ => Outputable (GenStgRhs bndr bdee) where
ppr sty rhs = pprStgRhs sty rhs
\end{code}
\begin{code}
-pprStgAtom :: (Outputable bdee) => PprStyle -> StgAtom bdee -> Pretty
+pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
-pprStgAtom sty (StgVarAtom var) = ppr sty var
-pprStgAtom sty (StgLitAtom lit) = ppr sty lit
+pprStgArg sty (StgVarArg var) = ppr sty var
+pprStgArg sty (StgLitArg lit) = ppr sty lit
\end{code}
\begin{code}
pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
- PprStyle -> StgExpr bndr bdee -> Pretty
+ PprStyle -> GenStgExpr bndr bdee -> Pretty
-- special case
pprStgExpr sty (StgApp func [] lvs)
= ppBeside (ppr sty func) (pprStgLVs sty lvs)
\end{code}
\begin{code}
-pprStgExpr sty (StgConApp con args lvs)
+pprStgExpr sty (StgCon con args lvs)
= ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
ppStr "! [", interppSP sty args, ppStr "]" ]
-pprStgExpr sty (StgPrimApp op args lvs)
+pprStgExpr sty (StgPrim op args lvs)
= ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
ppStr " [", interppSP sty args, ppStr "]" ]
\end{code}
-- special case: let v = <very specific thing>
-- in
-- let ...
--- in
+-- in
-- ...
--
-- Very special! Suspicious! (SLPJ)
-pprStgExpr sty (StgLet (StgNonRec binder (StgRhsClosure cc bi free_vars upd_flag args rhs))
+pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
expr@(StgLet _ _))
= ppAbove
- (ppHang (ppBesides [ppStr "let { ", ppr sty binder, ppStr " = ",
- ppStr (showCostCentre sty True{-as string-} cc),
+ (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
+ ppStr (showCostCentre sty True{-as string-} cc),
pp_binder_info sty bi,
- ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
- ppr sty upd_flag, ppStr " [",
- interppSP sty args, ppStr "]"])
+ ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
+ ppr sty upd_flag, ppStr " [",
+ interppSP sty args, ppStr "]"])
8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
(ppr sty expr)
= ppHang (ppCat [ppr sty lit, ppStr "->"])
4 (ppBeside (ppr sty expr) ppSemi)
-#ifdef DPH
- ppr_alts sty (StgParAlgAlts ty dim params alts deflt)
- = ppAboves [ ppBeside (ppCat (map (ppr sty) params))
- (ppCat [ppStr "|" , ppr sty dim , ppStr "|"]),
- ppAboves (map (ppr_bxd_alt sty) alts),
- ppr_default sty deflt ]
- where
- ppr_bxd_alt sty (con, expr)
- = ppHang (ppCat [ppStr "\\/", ppr_con sty con, ppStr "->"])
- 4 (ppr sty expr)
- where
- ppr_con sty con
- = if isOpLexeme con
- then ppBesides [ppLparen, ppr sty con, ppRparen]
- else ppr sty con
-
- ppr_alts sty (StgParPrimAlts ty dim alts deflt)
- = ppAboves [ ifPprShowAll sty (ppr sty ty),
- ppCat [ppStr "|" , ppr sty dim , ppStr "|"],
- ppAboves (map (ppr_ubxd_alt sty) alts),
- ppr_default sty deflt ]
- where
- ppr_ubxd_alt sty (lit, expr)
- = ppHang (ppCat [ppStr "\\/", ppr sty lit, ppStr "->"]) 4 (ppr sty expr)
-#endif {- Data Parallel Haskell -}
-
ppr_default sty StgNoDefault = ppNil
- ppr_default sty (StgBindDefault binder used expr)
+ ppr_default sty (StgBindDefault bndr used expr)
= ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
where
- pp_binder = if used then ppr sty binder else ppChar '_'
-\end{code}
-
-\begin{code}
-#ifdef DPH
-pprStgExpr sty (StgParConApp con dim args lvs)
- = ppBesides [ppr sty con, pprStgLVs sty lvs, ppStr "!<<" ,ppr sty dim ,
- ppStr ">> [", interppSP sty args, ppStr "]" ]
-
-pprStgExpr sty (StgParComm dim expr comm)
- = ppSep [ppSep [ppStr "COMM ",
- ppNest 2 (pprStgExpr sty expr),ppStr "{"],
- ppNest 2 (ppr_comm sty comm),
- ppStr "}"]
- where
- ppr_comm sty (StgParSend args)
- = ppSep [ppStr "SEND [",interppSP sty args, ppStr "]" ]
- ppr_comm sty (StgParFetch args)
- = ppSep [ppStr "FETCH [",interppSP sty args, ppStr "]" ]
- ppr_comm sty (StgToPodized)
- = ppStr "ToPodized"
- ppr_comm sty (StgFromPodized)
- = ppStr "FromPodized"
-#endif {- Data Parallel Haskell -}
+ pp_binder = if used then ppr sty bndr else ppChar '_'
\end{code}
\begin{code}
--- pprStgLVs :: PprStyle -> StgLiveVars bindee -> Pretty
+-- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
pprStgLVs PprForUser lvs = ppNil
\begin{code}
pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
- PprStyle -> StgRhs bndr bdee -> Pretty
+ PprStyle -> GenStgRhs bndr bdee -> Pretty
-- special case
pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
from the STG bindings.
\begin{code}
-stgArity :: PlainStgRhs -> Int
+stgArity :: StgRhs -> Int
stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
stgArity (StgRhsClosure _ _ _ _ args _ ) = length args
x%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
%
-\section[StgFuns]{Utility functions for @STG@ programs}
+\section[StgUtils]{Utility functions for @STG@ programs}
\begin{code}
#include "HsVersions.h"
-module StgFuns (
- mapStgBindeesRhs
- ) where
+module StgUtils ( mapStgBindeesRhs ) where
import StgSyn
import UniqSet
-import Unique
import Util
\end{code}
bindee in the program.
\begin{code}
-mapStgBindeesBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding
+mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding
mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs)
mapStgBindeesBind fn (StgRec pairs) = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
------------------
-mapStgBindeesRhs :: (Id -> Id) -> PlainStgRhs -> PlainStgRhs
+mapStgBindeesRhs :: (Id -> Id) -> StgRhs -> StgRhs
mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr)
- = StgRhsClosure
- cc bi
- (map fn fvs)
- u
- (map fn args)
+ = StgRhsClosure
+ cc bi
+ (map fn fvs)
+ u
+ (map fn args)
(mapStgBindeesExpr fn expr)
mapStgBindeesRhs fn (StgRhsCon cc con atoms)
= StgRhsCon cc con (map (mapStgBindeesAtom fn) atoms)
------------------
-mapStgBindeesExpr :: (Id -> Id) -> PlainStgExpr -> PlainStgExpr
+mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr
mapStgBindeesExpr fn (StgApp f args lvs)
- = StgApp (mapStgBindeesAtom fn f)
- (map (mapStgBindeesAtom fn) args)
+ = StgApp (mapStgBindeesAtom fn f)
+ (map (mapStgBindeesAtom fn) args)
(mapUniqSet fn lvs)
-mapStgBindeesExpr fn (StgConApp con atoms lvs)
- = StgConApp con (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
+mapStgBindeesExpr fn (StgCon con atoms lvs)
+ = StgCon con (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
-mapStgBindeesExpr fn (StgPrimApp op atoms lvs)
- = StgPrimApp op (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
+mapStgBindeesExpr fn (StgPrim op atoms lvs)
+ = StgPrim op (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs)
mapStgBindeesExpr fn (StgLet bind expr)
= StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr)
mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr)
------------------
-mapStgBindeesAtom :: (Id -> Id) -> PlainStgAtom -> PlainStgAtom
+mapStgBindeesAtom :: (Id -> Id) -> StgArg -> StgArg
-mapStgBindeesAtom fn a@(StgLitAtom _) = a
-mapStgBindeesAtom fn a@(StgVarAtom id) = StgVarAtom (fn id)
+mapStgBindeesAtom fn a@(StgLitArg _) = a
+mapStgBindeesAtom fn a@(StgVarArg id) = StgVarArg (fn id)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SaAbsInt where
-import CoreSyn(CoreExpr)
-import Id(Id)
-import IdInfo(Demand)
-import SaLib(AbsVal, AbsValEnv, AnalysisKind)
-import UniType(UniType)
-absEval :: AnalysisKind -> CoreExpr Id Id -> AbsValEnv -> AbsVal
-findDemand :: AbsValEnv -> AbsValEnv -> CoreExpr Id Id -> Id -> Demand
-findStrictness :: (Bool, Bool) -> [UniType] -> AbsVal -> AbsVal -> [Demand]
-fixpoint :: AnalysisKind -> [Id] -> [CoreExpr Id Id] -> AbsValEnv -> [AbsVal]
-isBot :: AbsVal -> Bool
-widen :: AnalysisKind -> AbsVal -> AbsVal
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[SaAbsInt]{Abstract interpreter for strictness analysis}
--import FiniteMap
import Outputable
-import AbsPrel ( PrimOp(..),
+import PrelInfo ( PrimOp(..),
intTyCon, integerTyCon, doubleTyCon,
floatTyCon, wordTyCon, addrTyCon,
- PrimKind
+ PrimRep
)
-import AbsUniType ( isPrimType, getUniDataTyCon_maybe,
+import Type ( isPrimType, maybeDataTyCon,
maybeSingleConstructorTyCon,
returnsRealWorld,
isEnumerationTyCon, TyVarTemplate, TyCon
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
)
-import Id ( getIdStrictness, getIdUniType, getIdUnfolding,
+import CoreUtils ( unTagBinders )
+import Id ( getIdStrictness, idType, getIdUnfolding,
getDataConSig, getInstantiatedDataConSig,
DataCon(..), isBottomingId
)
-
import IdInfo -- various bits
-import IdEnv
-import CoreFuns ( unTagBinders )
import Maybes ( maybeToBool, Maybe(..) )
-import PlainCore
import SaLib
-import SimplEnv ( FormSummary(..) ) -- nice data abstraction, huh? (WDP 95/03)
import Util
\end{code}
-- always returns bottom, such as \y.x,
-- when x is bound to bottom.
-lub (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys)
- AbsProd (zipWith lub xs ys)
+lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual lub xs ys)
lub _ _ = AbsTop -- Crude, but conservative
- -- The crudity only shows up if there
+ -- The crudity only shows up if there
-- are functions involved
-- Slightly funny glb; for absence analysis only;
--
-- f = \a b -> ...
--
--- g = \x y z -> case x of
+-- g = \x y z -> case x of
-- [] -> f x
-- (p:ps) -> f p
--
-- Deal with functions specially, because AbsTop isn't the
-- top of their domain.
-glb v1 v2
+glb v1 v2
| is_fun v1 || is_fun v2
- = if not (anyBot v1) && not (anyBot v2)
+ = if not (anyBot v1) && not (anyBot v2)
then
AbsTop
else
-- The non-functional cases are quite straightforward
-glb (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys)
- AbsProd (zipWith glb xs ys)
+glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual glb xs ys)
glb AbsTop v2 = v2
glb v1 AbsTop = v1
-combineCaseValues
+combineCaseValues
:: AnalysisKind
-> AbsVal -- Value of scrutinee
-> [AbsVal] -- Value of branches (at least one)
AbsTop -> True; -- i.e., cool
AbsProd _ -> True; -- ditto
_ -> False -- party over
- }
+ }
-- For absence analysis, check if the scrutinee is all poison (isBot)
-- If so, return poison (AbsBot); otherwise, any nested poison will come
isBot AbsBot = True
isBot (AbsFun args body env) = isBot (absEval StrAnal body env)
- -- Don't bother to extend the envt because
- -- unbound variables default to AbsTop anyway
+ -- Don't bother to extend the envt because
+ -- unbound variables default to AbsTop anyway
isBot other = False
\end{code}
\begin{code}
widen :: AnalysisKind -> AbsVal -> AbsVal
-widen StrAnal (AbsFun args body env)
+widen StrAnal (AbsFun args body env)
| isBot (absEval StrAnal body env) = AbsBot
| otherwise
= ASSERT (not (null args))
-- alternative here would be to bind g to its exact abstract
-- value, but that entails lots of potential re-computation, at
-- every application of g.)
-
+
widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
widen StrAnal other_val = other_val
-widen AbsAnal (AbsFun args body env)
+widen AbsAnal (AbsFun args body env)
| anyBot (absEval AbsAnal body env) = AbsBot
-- In the absence-analysis case it's *essential* to check
-- that the function has no poison in its body. If it does,
| otherwise
= ASSERT (not (null args))
AbsApproxFun (map (findDemandAbsOnly env body) args)
-
+
widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
-- It's desirable to do a good job of widening for product
widen AbsAnal other_val = other_val
--- OLD if anyBot val then AbsBot else AbsTop
+-- WAS: if anyBot val then AbsBot else AbsTop
-- Nowadays widen is doing a better job on functions for absence analysis.
\end{code}
sameVal AbsTop AbsTop = True
sameVal AbsTop other = False -- Right?
-sameVal (AbsProd vals1) (AbsProd vals2) = ASSERT (length vals1 == length vals2)
- and (zipWith sameVal vals1 vals2)
+sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual sameVal vals1 vals2)
sameVal (AbsProd _) AbsTop = False
sameVal (AbsProd _) AbsBot = False
(@True@ is the exciting answer; @False@ is always safe.)
\begin{code}
-evalStrictness :: Demand
- -> AbsVal
- -> Bool -- True iff the value is sure
+evalStrictness :: Demand
+ -> AbsVal
+ -> Bool -- True iff the value is sure
-- to be less defined than the Demand
evalStrictness (WwLazy _) _ = False
= case val of
AbsTop -> False
AbsBot -> True
- AbsProd vals -> ASSERT (length vals == length demand_info)
- or (zipWith evalStrictness demand_info vals)
+ AbsProd vals -> or (zipWithEqual evalStrictness demand_info vals)
_ -> trace "evalStrictness?" False
evalStrictness WwPrim val
= case val of
- AbsTop -> False
+ AbsTop -> False
- other -> -- A primitive value should be defined, never bottom;
+ other -> -- A primitive value should be defined, never bottom;
-- hence this paranoia check
pprPanic "evalStrictness: WwPrim:" (ppr PprDebug other)
\end{code}
possibly} hit poison.
\begin{code}
-evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
+evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison
-- with Absent demand
evalAbsence (WwUnpack demand_info) val
= case val of
AbsTop -> False -- No poison in here
AbsBot -> True -- Pure poison
- AbsProd vals -> ASSERT (length demand_info == length vals)
- or (zipWith evalAbsence demand_info vals)
+ AbsProd vals -> or (zipWithEqual evalAbsence demand_info vals)
_ -> panic "evalAbsence: other"
evalAbsence other val = anyBot val
result =
case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of
- (Just abs_val, _, _) ->
+ (Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, LiteralForm _) ->
+ (Nothing, NoStrictnessInfo, LitForm _) ->
AbsTop -- Literals all terminate, and have no poison
- (Nothing, NoStrictnessInfo, ConstructorForm _ _ _) ->
+ (Nothing, NoStrictnessInfo, ConForm _ _ _) ->
AbsTop -- An imported constructor won't have
-- bottom components, nor poison!
- (Nothing, NoStrictnessInfo, GeneralForm _ _ 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
-- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
- (Nothing, strictness_info, _) ->
+ (Nothing, strictness_info, _) ->
-- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails
-- Try the strictness info
absValFromStrictness anal strictness_info
-- Done via strictness now
- -- GeneralForm _ BottomForm _ _ -> AbsBot
+ -- GenForm _ BottomForm _ _ -> AbsBot
in
-- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) (
result
pp_anal StrAnal = ppStr "STR"
pp_anal AbsAnal = ppStr "ABS"
-absEvalAtom anal (CoVarAtom v) env = absId anal v env
-absEvalAtom anal (CoLitAtom _) env = AbsTop
+absEvalAtom anal (VarArg v) env = absId anal v env
+absEvalAtom anal (LitArg _) env = AbsTop
\end{code}
\begin{code}
-absEval :: AnalysisKind -> PlainCoreExpr -> AbsValEnv -> AbsVal
+absEval :: AnalysisKind -> CoreExpr -> AbsValEnv -> AbsVal
-absEval anal (CoVar var) env = absId anal var env
+absEval anal (Var var) env = absId anal var env
-absEval anal (CoLit _) env = AbsTop
+absEval anal (Lit _) env = AbsTop
-- What if an unboxed literal? That's OK: it terminates, so its
-- abstract value is AbsTop.
to make sure that any poison (?????)
\begin{code}
-absEval StrAnal (CoPrim SeqOp [t] [e]) env
+absEval StrAnal (Prim SeqOp [t] [e]) env
= if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
-- This is a special case to ensure that seq# is strict in its argument.
-- The comments below (for most normal PrimOps) do not apply.
-absEval StrAnal (CoPrim op ts es) env = AbsTop
+absEval StrAnal (Prim op ts es) env = AbsTop
-- The arguments are all of unboxed type, so they will already
-- have been eval'd. If the boxed version was bottom, we'll
-- already have returned bottom.
-- uses boxed args and we don't know whether or not it's
-- strict, so we assume laziness. (JSM)
-absEval AbsAnal (CoPrim op ts as) env
+absEval AbsAnal (Prim op ts as) env
= if any anyBot [absEvalAtom AbsAnal a env | a <- as]
then AbsBot
else AbsTop
-- For absence analysis, we want to see if the poison shows up...
-absEval anal (CoCon con ts as) env
+absEval anal (Con con ts as) env
| has_single_con
= AbsProd [absEvalAtom anal a env | a <- as]
| otherwise -- Not single-constructor
= case anal of
StrAnal -> -- Strictness case: it's easy: it certainly terminates
- AbsTop
- AbsAnal -> -- In the absence case we need to be more
+ AbsTop
+ AbsAnal -> -- In the absence case we need to be more
-- careful: look to see if there's any
-- poison in the components
if any anyBot [absEvalAtom AbsAnal a env | a <- as]
\end{code}
\begin{code}
-absEval anal (CoLam [] body) env = absEval anal body env -- paranoia
-absEval anal (CoLam binders body) env = AbsFun binders body env
-absEval anal (CoTyLam ty expr) env = absEval anal expr env
-absEval anal (CoApp e1 e2) env = absApply anal (absEval anal e1 env)
- (absEvalAtom anal e2 env)
-absEval anal (CoTyApp expr ty) env = absEval anal expr env
+absEval anal (Lam binder body) env
+ = AbsFun [binder] body env
+absEval anal (CoTyLam ty expr) env
+ = absEval anal expr env
+absEval anal (App e1 e2) env
+ = absApply anal (absEval anal e1 env) (absEvalAtom anal e2 env)
+absEval anal (CoTyApp expr ty) env
+ = absEval anal expr env
\end{code}
For primitive cases, just GLB the branches, then LUB with the expr part.
\begin{code}
-absEval anal (CoCase expr (CoPrimAlts alts deflt)) env
+absEval anal (Case expr (PrimAlts alts deflt)) env
= let
expr_val = absEval anal expr env
abs_alts = [ absEval anal rhs env | (_, rhs) <- alts ]
combineCaseValues anal expr_val
(abs_deflt ++ abs_alts)
-absEval anal (CoCase expr (CoAlgAlts alts deflt)) env
+absEval anal (Case expr (AlgAlts alts deflt)) env
= let
- expr_val = absEval anal expr env
+ expr_val = absEval anal expr env
abs_alts = [ absEvalAlgAlt anal expr_val alt env | alt <- alts ]
abs_deflt = absEvalDefault anal expr_val deflt env
in
result
\end{code}
-For @CoLets@ we widen the value we get. This is nothing to
+For @Lets@ we widen the value we get. This is nothing to
do with fixpointing. The reason is so that we don't get an explosion
in the amount of computation. For example, consider:
\begin{verbatim}
f x = case x of
p1 -> ...g r...
p2 -> ...g s...
- in
+ in
f e
\end{verbatim}
If we bind @f@ and @g@ to their exact abstract value, then we'll
and be prepared to bale out.
\begin{code}
-absEval anal (CoLet (CoNonRec binder e1) e2) env
+absEval anal (Let (NonRec binder e1) e2) env
= let
new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
in
- -- The binder of a CoNonRec should *not* be of unboxed type,
+ -- The binder of a NonRec should *not* be of unboxed type,
-- hence no need to strictly evaluate the Rhs.
absEval anal e2 new_env
-absEval anal (CoLet (CoRec pairs) body) env
+absEval anal (Let (Rec pairs) body) env
= let
(binders,rhss) = unzip pairs
rhs_vals = cheapFixpoint anal binders rhss env -- Returns widened values
new_env = growAbsValEnvList env (binders `zip` rhs_vals)
in
absEval anal body new_env
-\end{code}
-
-\begin{code}
-absEval anal (CoSCC cc expr) env = absEval anal expr env
--- ToDo: add DPH stuff here
+absEval anal (SCC cc expr) env = absEval anal expr env
\end{code}
\begin{code}
-absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],PlainCoreExpr) -> AbsValEnv -> AbsVal
+absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],CoreExpr) -> AbsValEnv -> AbsVal
absEvalAlgAlt anal (AbsProd arg_vals) (con, args, rhs) env
= -- The scrutinee is a product value, so it must be of a single-constr
_ -> False -- party over
}
-
-absEvalDefault :: AnalysisKind
+
+absEvalDefault :: AnalysisKind
-> AbsVal -- Value of scrutinee
- -> PlainCoreCaseDefault
- -> AbsValEnv
+ -> CoreCaseDefault
+ -> AbsValEnv
-> [AbsVal] -- Empty or singleton
-absEvalDefault anal scrut_val CoNoDefault env = []
-absEvalDefault anal scrut_val (CoBindDefault binder expr) env
+absEvalDefault anal scrut_val NoDefault env = []
+absEvalDefault anal scrut_val (BindDefault binder expr) env
= [absEval anal expr (addOneToAbsValEnv env binder scrut_val)]
\end{code}
-- AbsBot represents the abstract bottom *function* too
absApply StrAnal AbsTop arg = AbsTop
-absApply AbsAnal AbsTop arg = if anyBot arg
+absApply AbsAnal AbsTop arg = if anyBot arg
then AbsBot
else AbsTop
-- To be conservative, we have to assume that a function about
\end{code}
An @AbsFun@ with only one more argument needed---bind it and eval the
-result. A @CoLam@ with two or more args: return another @AbsFun@ with
+result. A @Lam@ with two or more args: return another @AbsFun@ with
an augmented environment.
\begin{code}
\begin{code}
findStrictness :: StrAnalFlags
- -> [UniType] -- Types of args in which strictness is wanted
- -> AbsVal -- Abstract strictness value of function
+ -> [Type] -- Types of args in which strictness is wanted
+ -> AbsVal -- Abstract strictness value of function
-> AbsVal -- Abstract absence value of function
-> [Demand] -- Resulting strictness annotation
\begin{code}
findDemandStrOnly str_env expr binder -- Only strictness environment available
- = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
+ = findRecDemand strflags [] str_fn abs_fn (idType binder)
where
str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
abs_fn val = AbsBot -- Always says poison; so it looks as if
strflags = getStrAnalFlags str_env
findDemandAbsOnly abs_env expr binder -- Only absence environment available
- = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
+ = findRecDemand strflags [] str_fn abs_fn (idType binder)
where
str_fn val = AbsBot -- Always says non-termination;
-- that'll make findRecDemand peer into the
-- structure of the value.
abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
strflags = getStrAnalFlags abs_env
-
+
findDemand str_env abs_env expr binder
- = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
+ = findRecDemand strflags [] str_fn abs_fn (idType binder)
where
str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
-- zooming into recursive types
-> (AbsVal -> AbsVal) -- The strictness function
-> (AbsVal -> AbsVal) -- The absence function
- -> UniType -- The type of the argument
+ -> Type -- The type of the argument
-> Demand
findRecDemand strflags seen str_fn abs_fn ty
else -- It's strict (or we're pretending it is)!
- case getUniDataTyCon_maybe ty of
+ case maybeDataTyCon ty of
Nothing -> wwStrict
(all_strict, num_strict) = strflags
is_numeric_type ty
- = case (getUniDataTyCon_maybe ty) of -- NB: duplicates stuff done above
+ = case (maybeDataTyCon ty) of -- NB: duplicates stuff done above
Nothing -> False
Just (tycon, _, _)
| tycon `is_elem`
approximation.
\begin{code}
-cheapFixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal]
+cheapFixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
cheapFixpoint AbsAnal [id] [rhs] env
= [crudeAbsWiden (absEval AbsAnal rhs new_env)]
= [widen anal (absEval anal rhs new_env) | rhs <- rhss]
-- We do just one iteration, starting from a safe
-- approximation. This won't do a good job in situations
- -- like:
+ -- like:
-- \x -> letrec f = ...g...
-- g = ...f...x...
-- in
\end{verbatim}
\begin{code}
-fixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal]
+fixpoint :: AnalysisKind -> [Id] -> [CoreExpr] -> AbsValEnv -> [AbsVal]
fixpoint anal [] _ env = []
-fixpoint anal ids rhss env
+fixpoint anal ids rhss env
= fix_loop initial_vals
where
initial_val id
= case anal of -- The (unsafe) starting point
- StrAnal -> if (returnsRealWorld (getIdUniType id))
+ StrAnal -> if (returnsRealWorld (idType id))
then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
else AbsBot
AbsAnal -> AbsTop
fix_loop :: [AbsVal] -> [AbsVal]
- fix_loop current_widened_vals
+ fix_loop current_widened_vals
= let
new_env = growAbsValEnvList env (ids `zip` current_widened_vals)
new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
new_widened_vals = map (widen anal) new_vals
- in
+ in
if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
current_widened_vals
+ -- NB: I was too chicken to make that a zipWithEqual,
+ -- lest I jump into a black hole. WDP 96/02
+
-- Return the widened values. We might get a slightly
-- better value by returning new_vals (which we used to
-- do, see below), but alas that means that whenever the
letrec
x = ...p..d...
d = (x,y)
- in
+ in
...
\end{verbatim}
Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface SaLib where
-import BasicLit(BasicLit)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdEnv(IdEnv(..))
-import IdInfo(Demand, StrictnessInfo)
-import Maybes(Labda)
-import Outputable(Outputable)
-import PlainCore(PlainCoreExpr(..))
-import PrimOps(PrimOp)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data AbsVal = AbsTop | AbsBot | AbsProd [AbsVal] | AbsFun [Id] (CoreExpr Id Id) AbsValEnv | AbsApproxFun [Demand]
-data AbsValEnv
-type AbsenceEnv = AbsValEnv
-data AnalysisKind = StrAnal | AbsAnal
-data CoreExpr a b
-data Id
-type IdEnv a = UniqFM a
-data Demand
-type PlainCoreExpr = CoreExpr Id Id
-type StrAnalFlags = (Bool, Bool)
-type StrictEnv = AbsValEnv
-data UniqFM a
-data Unique
-absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
-addOneToAbsValEnv :: AbsValEnv -> Id -> AbsVal -> AbsValEnv
-getStrAnalFlags :: AbsValEnv -> (Bool, Bool)
-growAbsValEnvList :: AbsValEnv -> [(Id, AbsVal)] -> AbsValEnv
-lookupAbsValEnv :: AbsValEnv -> Id -> Labda AbsVal
-nullAbsValEnv :: (Bool, Bool) -> AbsValEnv
-instance Outputable AbsVal
-instance Text AnalysisKind
-
StrAnalFlags(..), getStrAnalFlags,
nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList,
lookupAbsValEnv,
- absValFromStrictness,
+ absValFromStrictness
-- and to make the interface self-sufficient...
- CoreExpr, Id, IdEnv(..), UniqFM, Unique,
- Demand, PlainCoreExpr(..)
) where
-import IdEnv
import IdInfo
---import FiniteMap -- debugging only
import Outputable
-import PlainCore
import Pretty
-import Util -- for pragmas only
\end{code}
%************************************************************************
| AbsFun -- An abstract function, with the given:
[Id] -- arguments
- PlainCoreExpr -- body
+ CoreExpr -- body
AbsValEnv -- and environment
| AbsApproxFun -- This is used to represent a coarse
-- argument if the i'th element of the Demand
-- list so indicates.
-- The list of arguments is always non-empty.
- -- In effect, AbsApproxFun [] = AbsTop
+ -- In effect, AbsApproxFun [] = AbsTop
instance Outputable AbsVal where
ppr sty AbsTop = ppStr "AbsTop"
An @AbsValEnv@ maps @Ids@ to @AbsVals@. Any unbound @Ids@ are
implicitly bound to @AbsTop@, the completely uninformative,
-pessimistic value---see @absEval@ of a @CoVar@.
+pessimistic value---see @absEval@ of a @Var@.
\begin{code}
data AbsValEnv = AbsValEnv StrAnalFlags (IdEnv AbsVal)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface StrictAnal where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-saTopBinds :: (Bool, Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-saWwTopBinds :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[StrictAnal]{``Simple'' Mycroft-style strictness analyser}
module StrictAnal ( saWwTopBinds, saTopBinds ) where
-IMPORT_Trace
-import Outputable
-import Pretty
-
-import CmdLineOpts ( GlobalSwitch(..) )
-import CoreSyn -- ToDo: get pprCoreBinding straight from PlainCore?
import Id ( addIdDemandInfo, isWrapperId, addIdStrictness,
- getIdUniType, getIdDemandInfo
- IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling
+ idType, getIdDemandInfo
)
-import IdEnv
import IdInfo
-import PlainCore
import SaAbsInt
import SaLib
-import SplitUniq
-import Unique
+import UniqSupply
import Util
import WorkWrap -- "back-end" of strictness analyser
import WwLib ( WwM(..) )
and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to
f = \x -> case x of Int x# -> fw x#
- fw = \x# -> let x = Int x#
- in
+ fw = \x# -> let x = Int x#
+ in
let v = <expensive>
in <body>
-because this obviously loses laziness, since now <expensive>
+because this obviously loses laziness, since now <expensive>
is done each time. Alas.
WATCH OUT! This can mean that something is unboxed only to be
%************************************************************************
\begin{code}
-saWwTopBinds :: SplitUniqSupply
+saWwTopBinds :: UniqSupply
-> (GlobalSwitch -> Bool)
- -> [PlainCoreBinding]
- -> [PlainCoreBinding]
+ -> [CoreBinding]
+ -> [CoreBinding]
saWwTopBinds us switch_chker binds
= let
@AbsValEnv@ maps an @Id@ to its @AbsVal@).
\begin{code}
-saTopBinds :: StrAnalFlags -> [PlainCoreBinding] -> [PlainCoreBinding] -- exported
-sa_top_binds :: StrAnalFlags -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
+saTopBinds :: StrAnalFlags -> [CoreBinding] -> [CoreBinding] -- exported
+sa_top_binds :: StrAnalFlags -> [CoreBinding] -> SaM [CoreBinding] -- not exported
saTopBinds strflags binds
#ifndef OMIT_STRANAL_STATS
\begin{code}
saTopBind :: StrictEnv -> AbsenceEnv
- -> PlainCoreBinding
- -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding)
+ -> CoreBinding
+ -> SaM (StrictEnv, AbsenceEnv, CoreBinding)
-saTopBind str_env abs_env (CoNonRec binder rhs)
+saTopBind str_env abs_env (NonRec binder rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
let
strflags = getStrAnalFlags str_env
widened_str_rhs = widen StrAnal str_rhs
widened_abs_rhs = widen AbsAnal abs_rhs
-- The widening above is done for efficiency reasons.
- -- See notes on CoLet case in SaAbsInt.lhs
+ -- See notes on Let case in SaAbsInt.lhs
new_binder
= addStrictnessInfoToId
new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
in
- returnSa (new_str_env, new_abs_env, CoNonRec new_binder new_rhs)
+ returnSa (new_str_env, new_abs_env, NonRec new_binder new_rhs)
-saTopBind str_env abs_env (CoRec pairs)
+saTopBind str_env abs_env (Rec pairs)
= let
strflags = getStrAnalFlags str_env
(binders,rhss) = unzip pairs
-- fixpoint returns widened values
new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
- new_binders = zipWith4 (addStrictnessInfoToId strflags)
- str_rhss abs_rhss binders rhss
+ new_binders = zipWith4Equal (addStrictnessInfoToId strflags)
+ str_rhss abs_rhss binders rhss
in
mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
let
new_pairs = new_binders `zip` new_rhss
in
- returnSa (new_str_env, new_abs_env, CoRec new_pairs)
+ returnSa (new_str_env, new_abs_env, Rec new_pairs)
\end{code}
%************************************************************************
environment.
\begin{code}
-saExpr :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> SaM PlainCoreExpr
+saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr
-saExpr _ _ e@(CoVar _) = returnSa e
-saExpr _ _ e@(CoLit _) = returnSa e
-saExpr _ _ e@(CoCon _ _ _) = returnSa e
-saExpr _ _ e@(CoPrim _ _ _) = returnSa e
+saExpr _ _ e@(Var _) = returnSa e
+saExpr _ _ e@(Lit _) = returnSa e
+saExpr _ _ e@(Con _ _ _) = returnSa e
+saExpr _ _ e@(Prim _ _ _) = returnSa e
-saExpr str_env abs_env (CoLam args body)
+saExpr str_env abs_env (Lam arg body)
= saExpr str_env abs_env body `thenSa` \ new_body ->
let
- new_args = addDemandInfoToIds str_env abs_env body args
+ new_arg = addDemandInfoToId str_env abs_env body arg
in
- tickLambdas new_args `thenSa_` -- stats
- returnSa (CoLam new_args new_body)
+ tickLambda new_arg `thenSa_` -- stats
+ returnSa (Lam new_arg new_body)
saExpr str_env abs_env (CoTyLam ty expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
returnSa (CoTyLam ty new_expr)
-saExpr str_env abs_env (CoApp fun arg)
+saExpr str_env abs_env (App fun arg)
= saExpr str_env abs_env fun `thenSa` \ new_fun ->
- returnSa (CoApp new_fun arg)
+ returnSa (App new_fun arg)
saExpr str_env abs_env (CoTyApp expr ty)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
returnSa (CoTyApp new_expr ty)
-saExpr str_env abs_env (CoSCC cc expr)
+saExpr str_env abs_env (SCC cc expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (CoSCC cc new_expr)
+ returnSa (SCC cc new_expr)
-saExpr str_env abs_env (CoCase expr (CoAlgAlts alts deflt))
+saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
mapSa sa_alt alts `thenSa` \ new_alts ->
- returnSa (CoCase new_expr (CoAlgAlts new_alts new_deflt))
+ returnSa (Case new_expr (AlgAlts new_alts new_deflt))
where
sa_alt (con, binders, rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
tickCases new_binders `thenSa_` -- stats
returnSa (con, new_binders, new_rhs)
-saExpr str_env abs_env (CoCase expr (CoPrimAlts alts deflt))
+saExpr str_env abs_env (Case expr (PrimAlts alts deflt))
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
mapSa sa_alt alts `thenSa` \ new_alts ->
- returnSa (CoCase new_expr (CoPrimAlts new_alts new_deflt))
+ returnSa (Case new_expr (PrimAlts new_alts new_deflt))
where
sa_alt (lit, rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
returnSa (lit, new_rhs)
-saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body)
+saExpr str_env abs_env (Let (NonRec binder rhs) body)
= -- Analyse the RHS in the environment at hand
saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
let
widened_str_rhs = widen StrAnal str_rhs_val
widened_abs_rhs = widen AbsAnal abs_rhs_val
-- The widening above is done for efficiency reasons.
- -- See notes on CoLet case in SaAbsInt.lhs
+ -- See notes on Let case in SaAbsInt.lhs
new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs
new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs
in
tickLet new_binder `thenSa_` -- stats
saExpr new_str_env new_abs_env body `thenSa` \ new_body ->
- returnSa (CoLet (CoNonRec new_binder new_rhs) new_body)
+ returnSa (Let (NonRec new_binder new_rhs) new_body)
-saExpr str_env abs_env (CoLet (CoRec pairs) body)
+saExpr str_env abs_env (Let (Rec pairs) body)
= let
strflags = getStrAnalFlags str_env
(binders,rhss) = unzip pairs
mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
let
-- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders
--- DON'T add demand info in a CoRec!
+-- DON'T add demand info in a Rec!
-- a) it's useless: we can't do let-to-case
-- b) it's incorrect. Consider
-- letrec x = ...y...
-- deciding that y is absent, which is plain wrong!
-- It's much easier simply not to do this.
- improved_binders = zipWith4 (addStrictnessInfoToId strflags)
- str_vals abs_vals binders rhss
+ improved_binders = zipWith4Equal (addStrictnessInfoToId strflags)
+ str_vals abs_vals binders rhss
whiter_than_white_binders = launder improved_binders
new_pairs = whiter_than_white_binders `zip` new_rhss
in
- returnSa (CoLet (CoRec new_pairs) new_body)
+ returnSa (Let (Rec new_pairs) new_body)
where
launder me = {-still-} me
\end{code}
\begin{code}
-saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault
+saDefault str_env abs_env NoDefault = returnSa NoDefault
-saDefault str_env abs_env (CoBindDefault bdr rhs)
+saDefault str_env abs_env (BindDefault bdr rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
let
new_bdr = addDemandInfoToId str_env abs_env rhs bdr
in
tickCases [new_bdr] `thenSa_` -- stats
- returnSa (CoBindDefault new_bdr new_rhs)
+ returnSa (BindDefault new_bdr new_rhs)
\end{code}
tell how many args could safely be grabbed.
\begin{code}
-addStrictnessInfoToId
+addStrictnessInfoToId
:: StrAnalFlags
-> AbsVal -- Abstract strictness value
-> AbsVal -- Ditto absence
-> Id -- The id
- -> PlainCoreExpr -- Its RHS
+ -> CoreExpr -- Its RHS
-> Id -- Augmented with strictness
addStrictnessInfoToId strflags str_val abs_val binder body
= if isWrapperId binder then
- binder -- Avoid clobbering existing strictness info
+ binder -- Avoid clobbering existing strictness info
-- (and, more importantly, worker info).
-- Deeply suspicious (SLPJ)
else
if (isBot str_val) then
binder `addIdStrictness` mkBottomStrictnessInfo
else
- case (digForLambdas body) of { (_, lambda_bounds, rhs) ->
- let
- tys = map getIdUniType lambda_bounds
+ case (digForLambdas body) of { (_, _, lambda_bounds, rhs) ->
+ let
+ tys = map idType lambda_bounds
strictness = findStrictness strflags tys str_val abs_val
in
binder `addIdStrictness` mkStrictnessInfo strictness Nothing
\end{code}
\begin{code}
-addDemandInfoToId :: StrictEnv -> AbsenceEnv
- -> PlainCoreExpr -- The scope of the id
- -> Id
+addDemandInfoToId :: StrictEnv -> AbsenceEnv
+ -> CoreExpr -- The scope of the id
+ -> Id
-> Id -- Id augmented with Demand info
addDemandInfoToId str_env abs_env expr binder
= binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder))
-addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> [Id] -> [Id]
+addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> CoreExpr -> [Id] -> [Id]
-addDemandInfoToIds str_env abs_env expr binders
+addDemandInfoToIds str_env abs_env expr binders
= map (addDemandInfoToId str_env abs_env expr) binders
\end{code}
thenSa_ :: SaM a -> SaM b -> SaM b
returnSa :: a -> SaM a
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenSa #-}
{-# INLINE thenSa_ #-}
{-# INLINE returnSa #-}
-#endif
-tickLambdas :: [Id] -> SaM ()
-tickCases :: [Id] -> SaM ()
-tickLet :: Id -> SaM ()
+tickLambda :: [Id] -> SaM ()
+tickCases :: [Id] -> SaM ()
+tickLet :: Id -> SaM ()
#ifndef OMIT_STRANAL_STATS
type SaM a = SaStats -> (a, SaStats)
returnSa x stats = (x, stats)
-tickLambdas vars (SaStats tlam dlam tc dc tlet dlet)
- = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) ->
+tickLambda var (SaStats tlam dlam tc dc tlet dlet)
+ = case (tick_demanded (0,0) var) of { (IBOX(tot), IBOX(demanded)) ->
((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) }
tickCases vars (SaStats tlam dlam tc dc tlet dlet)
returnSa x = x
-tickLambdas vars = panic "OMIT_STRANAL_STATS: tickLambdas"
-tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
-tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
+tickLambda var = panic "OMIT_STRANAL_STATS: tickLambda"
+tickCases vars = panic "OMIT_STRANAL_STATS: tickCases"
+tickLet var = panic "OMIT_STRANAL_STATS: tickLet"
#endif {-OMIT_STRANAL_STATS-}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface WorkWrap where
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreBinding)
-import Id(Id)
-import SplitUniq(SplitUniqSupply)
-workersAndWrappers :: [CoreBinding Id Id] -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [CoreBinding Id Id]
-
import Outputable
import Pretty
-import Id ( getIdUniType, addIdStrictness, getIdStrictness,
+import Id ( idType, addIdStrictness, getIdStrictness,
getIdUnfolding, mkWorkerId,
replaceIdInfo, getIdInfo, idWantsToBeINLINEd
)
import IdInfo -- bits and pieces
import Maybes ( maybeToBool, Maybe(..) )
-import PlainCore
import SaLib
import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
import Util
\end{enumerate}
\begin{code}
-workersAndWrappers :: [PlainCoreBinding] -> WwM [PlainCoreBinding]
+workersAndWrappers :: [CoreBinding] -> WwM [CoreBinding]
workersAndWrappers top_binds
= mapWw (wwBind True{-top-level-}) top_binds `thenWw` \ top_binds2 ->
in
returnWw (concat top_binds3)
where
- make_top_binding :: WwBinding -> [PlainCoreBinding]
+ make_top_binding :: WwBinding -> [CoreBinding]
make_top_binding (WwLet binds) = binds
\end{code}
\begin{code}
wwBind :: Bool -- True <=> top-level binding
- -> PlainCoreBinding
+ -> CoreBinding
-> WwM WwBinding -- returns a WwBinding intermediate form;
-- the caller will convert to Expr/Binding,
-- as appropriate.
-wwBind top_level (CoNonRec binder rhs)
+wwBind top_level (NonRec binder rhs)
= wwExpr rhs `thenWw` \ new_rhs ->
tryWW binder new_rhs `thenWw` \ new_pairs ->
- returnWw (WwLet [CoNonRec b e | (b,e) <- new_pairs])
+ returnWw (WwLet [NonRec b e | (b,e) <- new_pairs])
-- Generated bindings must be non-recursive
-- because the original binding was.
------------------------------
-wwBind top_level (CoRec pairs)
+wwBind top_level (Rec pairs)
= mapWw do_one pairs `thenWw` \ new_pairs ->
- returnWw (WwLet [CoRec (concat new_pairs)])
+ returnWw (WwLet [Rec (concat new_pairs)])
where
do_one (binder, rhs) = wwExpr rhs `thenWw` \ new_rhs ->
tryWW binder new_rhs
???????????????? ToDo
\begin{code}
-wwExpr :: PlainCoreExpr -> WwM PlainCoreExpr
+wwExpr :: CoreExpr -> WwM CoreExpr
-wwExpr e@(CoVar _) = returnWw e
-wwExpr e@(CoLit _) = returnWw e
-wwExpr e@(CoCon _ _ _) = returnWw e
-wwExpr e@(CoPrim _ _ _) = returnWw e
+wwExpr e@(Var _) = returnWw e
+wwExpr e@(Lit _) = returnWw e
+wwExpr e@(Con _ _ _) = returnWw e
+wwExpr e@(Prim _ _ _) = returnWw e
-wwExpr (CoLam binders expr)
+wwExpr (Lam binders expr)
= wwExpr expr `thenWw` \ new_expr ->
- returnWw (CoLam binders new_expr)
+ returnWw (Lam binders new_expr)
wwExpr (CoTyLam ty expr)
= wwExpr expr `thenWw` \ new_expr ->
returnWw (CoTyLam ty new_expr)
-wwExpr (CoApp e1 e2)
+wwExpr (App e1 e2)
= wwExpr e1 `thenWw` \ new_e1 ->
- returnWw (CoApp new_e1 e2)
+ returnWw (App new_e1 e2)
wwExpr (CoTyApp expr ty)
= wwExpr expr `thenWw` \ new_expr ->
returnWw (CoTyApp new_expr ty)
-wwExpr (CoSCC cc expr)
+wwExpr (SCC cc expr)
= wwExpr expr `thenWw` \ new_expr ->
- returnWw (CoSCC cc new_expr)
+ returnWw (SCC cc new_expr)
-wwExpr (CoLet bind expr)
+wwExpr (Let bind expr)
= wwBind False{-not top-level-} bind `thenWw` \ intermediate_bind ->
wwExpr expr `thenWw` \ new_expr ->
returnWw (mash_ww_bind intermediate_bind new_expr)
mash_ww_bind (WwLet binds) body = mkCoLetsNoUnboxed binds body
mash_ww_bind (WwCase case_fn) body = case_fn body
-wwExpr (CoCase expr alts)
+wwExpr (Case expr alts)
= wwExpr expr `thenWw` \ new_expr ->
ww_alts alts `thenWw` \ new_alts ->
- returnWw (CoCase new_expr new_alts)
+ returnWw (Case new_expr new_alts)
where
- ww_alts (CoAlgAlts alts deflt)
+ ww_alts (AlgAlts alts deflt)
= mapWw ww_alg_alt alts `thenWw` \ new_alts ->
ww_deflt deflt `thenWw` \ new_deflt ->
- returnWw (CoAlgAlts new_alts new_deflt)
+ returnWw (AlgAlts new_alts new_deflt)
- ww_alts (CoPrimAlts alts deflt)
+ ww_alts (PrimAlts alts deflt)
= mapWw ww_prim_alt alts `thenWw` \ new_alts ->
ww_deflt deflt `thenWw` \ new_deflt ->
- returnWw (CoPrimAlts new_alts new_deflt)
+ returnWw (PrimAlts new_alts new_deflt)
ww_alg_alt (con, binders, rhs)
= wwExpr rhs `thenWw` \ new_rhs ->
= wwExpr rhs `thenWw` \ new_rhs ->
returnWw (lit, new_rhs)
- ww_deflt CoNoDefault
- = returnWw CoNoDefault
+ ww_deflt NoDefault
+ = returnWw NoDefault
- ww_deflt (CoBindDefault binder rhs)
+ ww_deflt (BindDefault binder rhs)
= wwExpr rhs `thenWw` \ new_rhs ->
- returnWw (CoBindDefault binder new_rhs)
+ returnWw (BindDefault binder new_rhs)
\end{code}
%************************************************************************
\begin{code}
tryWW :: Id -- the fn binder
- -> PlainCoreExpr -- the bound rhs; its innards
+ -> CoreExpr -- the bound rhs; its innards
-- are already ww'd
- -> WwM [(Id, PlainCoreExpr)] -- either *one* or *two* pairs;
+ -> WwM [(Id, CoreExpr)] -- either *one* or *two* pairs;
-- if one, then no worker (only
-- the orig "wrapper" lives on);
-- if two, then a worker and a
-- OK, it looks as if a worker is worth a try
let
- (tyvars, args, body) = digForLambdas rhs
- body_ty = typeOfCoreExpr body
+ (uvars, tyvars, args, body) = digForLambdas rhs
+ body_ty = coreExprType body
in
uniqSMtoWwM (mkWwBodies body_ty tyvars args args_info) `thenWw` \ result ->
case result of
- Nothing -> -- Very peculiar. This can only happen if we hit an
+ Nothing -> -- Very peculiar. This can only happen if we hit an
-- abstract type, which we shouldn't have since we've
-- constructed the args_info in this module!
-
+
-- False. We might hit the all-args-absent-and-the-
-- body-is-unboxed case. A Nothing is legit. (WDP 94/10)
do_nothing
-- worker Id:
mkStrictnessInfo args_info (Just worker_id)
- wrapper_id = fn_id `replaceIdInfo`
+ wrapper_id = fn_id `replaceIdInfo`
(getIdInfo fn_id `addInfo`
revised_strictness_info `addInfo_UF`
iWantToBeINLINEd UnfoldAlways)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface WwLib where
-import BasicLit(BasicLit)
-import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
-import Id(Id)
-import IdInfo(Demand, StrictnessInfo)
-import Maybes(Labda, MaybeErr)
-import PlainCore(PlainCoreBinding(..), PlainCoreExpr(..))
-import PrimOps(PrimOp)
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique)
-infixr 9 `thenWw`
-data GlobalSwitch
-data CoreBinding a b
-data CoreExpr a b
-data Id
-data Demand
-data MaybeErr a b
-type PlainCoreBinding = CoreBinding Id Id
-type PlainCoreExpr = CoreExpr Id Id
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply
-data TyVar
-data UniType
-data Unique
-data WwBinding = WwLet [CoreBinding Id Id] | WwCase (CoreExpr Id Id -> CoreExpr Id Id)
-type WwM a = SplitUniqSupply -> (GlobalSwitch -> Bool) -> a
-getUniqueWw :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> Unique
-mAX_WORKER_ARGS :: Int
-mapWw :: (a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b) -> [a] -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [b]
-mkWwBodies :: UniType -> [TyVar] -> [Id] -> [Demand] -> SplitUniqSupply -> Labda (Id -> CoreExpr Id Id, CoreExpr Id Id -> CoreExpr Id Id, StrictnessInfo, UniType -> UniType)
-returnWw :: a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> a
-thenWw :: (SplitUniqSupply -> (GlobalSwitch -> Bool) -> a) -> (a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b) -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b
-uniqSMtoWwM :: (SplitUniqSupply -> a) -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> a
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
-- our friendly worker/wrapper monad:
WwM(..),
returnWw, thenWw, mapWw,
- getUniqueWw, uniqSMtoWwM,
+ getUniqueWw, uniqSMtoWwM
-- and to make the interface self-sufficient...
- GlobalSwitch, CoreBinding, CoreExpr, PlainCoreBinding(..),
- PlainCoreExpr(..), Id, Demand, MaybeErr,
- TyVar, UniType, Unique, SplitUniqSupply, SUniqSM(..)
-
- IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique)
- IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
) where
-IMPORT_Trace
-import Outputable -- ToDo: rm (debugging)
-import Pretty
+import Ubiq{-uitous-}
-import AbsPrel ( aBSENT_ERROR_ID, mkFunTy )
-import AbsUniType ( mkTyVarTy, isPrimType, getUniDataTyCon_maybe,
- quantifyTy, TyVarTemplate
- )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( mkWorkerId, mkSysLocal, getIdUniType,
+import PrelInfo ( aBSENT_ERROR_ID )
+{-
+import Id ( mkWorkerId, mkSysLocal, idType,
getInstantiatedDataConSig, getIdInfo,
replaceIdInfo, addIdStrictness, DataCon(..)
)
import IdInfo -- lots of things
import Maybes ( maybeToBool, Maybe(..), MaybeErr )
-import PlainCore
import SaLib
import SrcLoc ( mkUnknownSrcLoc )
-import SplitUniq
-import Unique
-import Util
+import Type ( mkTyVarTy, mkFunTys, isPrimType,
+ maybeDataTyCon, quantifyTy
+ )
+import UniqSupply
+-}
+import Util ( panic )
infixr 9 `thenWw`
+
+quantifyTy = panic "WwLib.quantifyTy"
\end{code}
%************************************************************************
\begin{code}
data WwBinding
- = WwLet [PlainCoreBinding]
- | WwCase (PlainCoreExpr -> PlainCoreExpr)
+ = WwLet [CoreBinding]
+ | WwCase (CoreExpr -> CoreExpr)
-- the "case" will be a "strict let" of the form:
--
-- case rhs of
\begin{code}
mkWwBodies
- :: UniType -- Type of the *body* of the orig
+ :: Type -- Type of the *body* of the orig
-- function; i.e. /\ tyvars -> \ vars -> body
-> [TyVar] -- Type lambda vars of original function
-> [Id] -- Args of original function
-> [Demand] -- Strictness info for those args
- -> SUniqSM (Maybe -- Nothing iff (a) no interesting split possible
+ -> UniqSM (Maybe -- Nothing iff (a) no interesting split possible
-- (b) any unpack on abstract type
- (Id -> PlainCoreExpr, -- Wrapper expr w/
+ (Id -> CoreExpr, -- Wrapper expr w/
-- hole for worker id
- PlainCoreExpr -> PlainCoreExpr, -- Worker expr w/ hole
+ CoreExpr -> CoreExpr, -- Worker expr w/ hole
-- for original fn body
StrictnessInfo, -- Worker strictness info
- UniType -> UniType) -- Worker type w/ hole
+ Type -> Type) -- Worker type w/ hole
) -- for type of original fn body
-
+
mkWwBodies body_ty tyvars args arg_infos
= ASSERT(length args == length arg_infos)
-- or you can get disastrous user/definer-module mismatches
if (all_absent_args_and_unboxed_value body_ty arg_infos)
- then returnSUs Nothing
+ then returnUs Nothing
else -- the rest...
mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
`thenUsMaybe` \ (wrap_frag, work_args_info, work_frag) ->
- let
+ let
(work_args, wrkr_demands) = unzip work_args_info
wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker...
wrapper_w_hole = \ worker_id ->
- mkCoTyLam tyvars (
- mkCoLam args (
+ mkLam tyvars args (
wrap_frag (
- mkCoTyApps (CoVar worker_id) (map mkTyVarTy tyvars)
- )))
+ mkCoTyApps (Var worker_id) (map mkTyVarTy tyvars)
+ ))
worker_w_hole = \ orig_body ->
- mkCoTyLam tyvars (
- mkCoLam work_args (
+ mkLam tyvars work_args (
work_frag orig_body
- ))
+ )
worker_ty_w_hole = \ body_ty ->
snd (quantifyTy tyvars (
- foldr mkFunTy body_ty (map getIdUniType work_args)
+ mkFunTys (map idType work_args) body_ty
))
in
- returnSUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
+ returnUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole))
where
-- "all_absent_args_and_unboxed_value":
-- check for the obscure case of "\ x y z ... -> body" where
-- This prevents over-eager unpacking, leading
-- to huge-arity functions.
- -> SUniqSM (Maybe -- Nothing iff any unpack on abstract type
- (PlainCoreExpr -> PlainCoreExpr, -- Wrapper expr w/
+ -> UniqSM (Maybe -- Nothing iff any unpack on abstract type
+ (CoreExpr -> CoreExpr, -- Wrapper expr w/
-- hole for worker id
-- applied to types
[(Id,Demand)], -- Worker's args
- -- and their strictness info
- PlainCoreExpr -> PlainCoreExpr) -- Worker body expr w/ hole
+ -- and their strictness info
+ CoreExpr -> CoreExpr) -- Worker body expr w/ hole
) -- for original fn body
-mk_ww_arg_processing [] _ _ = returnSUs (Just (id, [], id))
+mk_ww_arg_processing [] _ _ = returnUs (Just (id, [], id))
mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
= -- Absent argument
-- So, finish args to the right...
--pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
let
- arg_ty = getIdUniType arg
+ arg_ty = idType arg
in
mk_ww_arg_processing args infos max_extra_args
-- we've already discounted for absent args,
`thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
-- wrapper doesn't pass this arg to worker:
- returnSUs (Just (
+ returnUs (Just (
-- wrapper:
\ hole -> wrap_rest hole,
where
mk_absent_let arg arg_ty body
= if not (isPrimType arg_ty) then
- CoLet (CoNonRec arg (mkCoTyApp (CoVar aBSENT_ERROR_ID) arg_ty))
- body
+ Let (NonRec arg (mkCoTyApp (Var aBSENT_ERROR_ID) arg_ty)) body
else -- quite horrible
panic "WwLib: haven't done mk_absent_let for primitives yet"
| new_max_extra_args > 0 -- Check that we are prepared to add arguments
= -- this is the complicated one.
--pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) (
- case getUniDataTyCon_maybe arg_ty of
+ case maybeDataTyCon arg_ty of
Nothing -> -- Not a data type
panic "mk_ww_arg_processing: not datatype"
Just (_, _, []) -> -- An abstract type
-- We have to give up on the whole idea
- returnSUs Nothing
+ returnUs Nothing
Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd
panic "mk_ww_arg_processing: multi-constr"
- Just (arg_tycon, tycon_arg_tys, [data_con]) ->
+ Just (arg_tycon, tycon_arg_tys, [data_con]) ->
-- The main event: a single-constructor data type
let
(_,inst_con_arg_tys,_)
- = getInstantiatedDataConSig data_con tycon_arg_tys
+ = getInstantiatedDataConSig data_con tycon_arg_tys
in
- getSUniques (length inst_con_arg_tys) `thenSUs` \ uniqs ->
+ getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
- let unpk_args = zipWith (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
- uniqs inst_con_arg_tys
+ let
+ unpk_args = zipWithEqual
+ (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
+ uniqs inst_con_arg_tys
in
-- In processing the rest, push the sub-component args
-- and infos on the front of the current bunch
mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
`thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
- returnSUs (Just (
+ returnUs (Just (
-- wrapper: unpack the value
\ hole -> mk_unpk_case arg unpk_args
data_con arg_tycon
))
--)
where
- arg_ty = getIdUniType arg
+ arg_ty = idType arg
new_max_extra_args
- = max_extra_args
+ = max_extra_args
+ 1 -- We won't pass the original arg now
- nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt
mk_unpk_case arg unpk_args boxing_con boxing_tycon body
- = CoCase (CoVar arg) (
- CoAlgAlts [(boxing_con, unpk_args, body)]
- CoNoDefault
+ = Case (Var arg) (
+ AlgAlts [(boxing_con, unpk_args, body)]
+ NoDefault
)
mk_pk_let arg boxing_con con_tys unpk_args body
- = CoLet (CoNonRec arg (CoCon boxing_con con_tys [CoVarAtom a | a <- unpk_args]))
+ = Let (NonRec arg (Con boxing_con con_tys [VarArg a | a <- unpk_args]))
body
mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
= -- For all others at the moment, we just
-- pass them to the worker unchanged.
--pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
-
+
-- Finish args to the right...
mk_ww_arg_processing args infos max_extra_args
`thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
-
- returnSUs (Just (
+
+ returnUs (Just (
-- wrapper:
- \ hole -> wrap_rest (CoApp hole (CoVarAtom arg)),
-
+ \ hole -> wrap_rest (App hole (VarArg arg)),
+
-- worker:
(arg, arg_demand) : work_args_info,
\ hole -> work_rest hole
- ))
+ ))
--)
\end{code}
\begin{code}
type WwM result
- = SplitUniqSupply
+ = UniqSupply
-> (GlobalSwitch -> Bool)
-> result
-#ifdef __GLASGOW_HASKELL__
{-# INLINE thenWw #-}
{-# INLINE returnWw #-}
-#endif
returnWw :: a -> WwM a
thenWw :: WwM a -> (a -> WwM b) -> WwM b
\begin{code}
getUniqueWw :: WwM Unique
-uniqSMtoWwM :: SUniqSM a -> WwM a
+uniqSMtoWwM :: UniqSM a -> WwM a
-getUniqueWw us sw_chk = getSUnique us
+getUniqueWw us sw_chk = getUnique us
uniqSMtoWwM u_obj us sw_chk = u_obj us
-thenUsMaybe :: SUniqSM (Maybe a) -> (a -> SUniqSM (Maybe b)) -> SUniqSM (Maybe b)
+thenUsMaybe :: UniqSM (Maybe a) -> (a -> UniqSM (Maybe b)) -> UniqSM (Maybe b)
thenUsMaybe m k
- = m `thenSUs` \ result ->
+ = m `thenUs` \ result ->
case result of
- Nothing -> returnSUs Nothing
+ Nothing -> returnUs Nothing
Just x -> k x
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface BackSubst where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsExpr(Expr)
-import HsLit(Literal)
-import HsMatches(GRHSsAndBinds, Match)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyVar(TyVar)
-import UniType(UniType)
-data Binds a b
-data MonoBinds a b
-data TypecheckedPat
-data Id
-data Subst
-applyTcSubstToBinds :: Binds Id TypecheckedPat -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Binds Id TypecheckedPat, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[BackSubst]{Back substitution functions}
-
-This module applies a typechecker substitution over the whole abstract
-syntax.
-
-\begin{code}
-#include "HsVersions.h"
-
-module BackSubst (
- applyTcSubstToBinds,
-
- -- and to make the interface self-sufficient...
- Subst, Binds, MonoBinds, Id, TypecheckedPat
- ) where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty
-
-import AbsSyn
-import AbsUniType ( getTyVar )
-import TcMonad
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-Binds]{Running a substitution over @Binds@}
-%* *
-%************************************************************************
-
-\begin{code}
-applyTcSubstToBinds :: TypecheckedBinds -> NF_TcM TypecheckedBinds
-
-applyTcSubstToBinds EmptyBinds = returnNF_Tc EmptyBinds
-
-applyTcSubstToBinds (ThenBinds binds1 binds2)
- = applyTcSubstToBinds binds1 `thenNF_Tc` \ new_binds1 ->
- applyTcSubstToBinds binds2 `thenNF_Tc` \ new_binds2 ->
- returnNF_Tc (ThenBinds new_binds1 new_binds2)
-
-applyTcSubstToBinds (SingleBind bind)
- = substBind bind `thenNF_Tc` \ new_bind ->
- returnNF_Tc (SingleBind new_bind)
-
-applyTcSubstToBinds (AbsBinds tyvars dicts locprs dict_binds val_bind)
- = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars ->
- mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
- mapNF_Tc subst_pair locprs `thenNF_Tc` \ new_locprs ->
- mapNF_Tc subst_bind dict_binds `thenNF_Tc` \ new_dict_binds ->
- substBind val_bind `thenNF_Tc` \ new_val_bind ->
- returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind)
- where
- subst_pair (l, g)
- = applyTcSubstToId l `thenNF_Tc` \ new_l ->
- applyTcSubstToId g `thenNF_Tc` \ new_g ->
- returnNF_Tc (new_l, new_g)
-
- subst_bind (v, e)
- = applyTcSubstToInst v `thenNF_Tc` \ new_v ->
- substExpr e `thenNF_Tc` \ new_e ->
- returnNF_Tc (new_v, new_e)
-\end{code}
-
-\begin{code}
--------------------------------------------------------------------------
-substBind :: TypecheckedBind -> NF_TcM TypecheckedBind
-
-substBind (NonRecBind mbinds)
- = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
- returnNF_Tc (NonRecBind new_mbinds)
-
-substBind (RecBind mbinds)
- = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
- returnNF_Tc (RecBind new_mbinds)
-
-substBind other = returnNF_Tc other
-
--------------------------------------------------------------------------
-applyTcSubstToMonoBinds :: TypecheckedMonoBinds -> NF_TcM TypecheckedMonoBinds
-
-applyTcSubstToMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds
-
-applyTcSubstToMonoBinds (AndMonoBinds mbinds1 mbinds2)
- = applyTcSubstToMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 ->
- applyTcSubstToMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 ->
- returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2)
-
-applyTcSubstToMonoBinds (PatMonoBind pat grhss_w_binds locn)
- = substPat pat `thenNF_Tc` \ new_pat ->
- substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
- returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn)
-
-applyTcSubstToMonoBinds (VarMonoBind var expr)
- = applyTcSubstToId var `thenNF_Tc` \ new_var ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (VarMonoBind new_var new_expr)
-
-applyTcSubstToMonoBinds (FunMonoBind name ms locn)
- = applyTcSubstToId name `thenNF_Tc` \ new_name ->
- mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms ->
- returnNF_Tc (FunMonoBind new_name new_ms locn)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
-%* *
-%************************************************************************
-
-\begin{code}
-substMatch :: TypecheckedMatch -> NF_TcM TypecheckedMatch
-
-substMatch (PatMatch pat match)
- = substPat pat `thenNF_Tc` \ new_pat ->
- substMatch match `thenNF_Tc` \ new_match ->
- returnNF_Tc (PatMatch new_pat new_match)
-
-substMatch (GRHSMatch grhss_w_binds)
- = substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
- returnNF_Tc (GRHSMatch new_grhss_w_binds)
-
--------------------------------------------------------------------------
-substGRHSsAndBinds :: TypecheckedGRHSsAndBinds
- -> NF_TcM TypecheckedGRHSsAndBinds
-
-substGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty)
- = mapNF_Tc subst_grhs grhss `thenNF_Tc` \ new_grhss ->
- applyTcSubstToBinds binds `thenNF_Tc` \ new_binds ->
- applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
- where
- subst_grhs (GRHS guard expr locn)
- = substExpr guard `thenNF_Tc` \ new_guard ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (GRHS new_guard new_expr locn)
-
- subst_grhs (OtherwiseGRHS expr locn)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (OtherwiseGRHS new_expr locn)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-Expr]{Running a substitution over a TypeCheckedExpr}
-%* *
-%************************************************************************
-
-ToDo: panic on things that can't be in @TypecheckedExpr@.
-
-\begin{code}
-substExpr :: TypecheckedExpr -> NF_TcM TypecheckedExpr
-
-substExpr (Var name)
- = applyTcSubstToId name `thenNF_Tc` \ new_name ->
- returnNF_Tc (Var new_name)
-
-substExpr (Lit (LitLitLit s ty))
- = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (Lit (LitLitLit s new_ty))
-
-substExpr other_lit@(Lit lit) = returnNF_Tc other_lit
-
-substExpr (Lam match)
- = substMatch match `thenNF_Tc` \ new_match ->
- returnNF_Tc (Lam new_match)
-
-substExpr (App e1 e2)
- = substExpr e1 `thenNF_Tc` \ new_e1 ->
- substExpr e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (App new_e1 new_e2)
-
-substExpr (OpApp e1 op e2)
- = substExpr e1 `thenNF_Tc` \ new_e1 ->
- substExpr op `thenNF_Tc` \ new_op ->
- substExpr e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (OpApp new_e1 new_op new_e2)
-
-substExpr (SectionL expr op)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- substExpr op `thenNF_Tc` \ new_op ->
- returnNF_Tc (SectionL new_expr new_op)
-
-substExpr (SectionR op expr)
- = substExpr op `thenNF_Tc` \ new_op ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (SectionR new_op new_expr)
-
-substExpr (CCall fun args may_gc is_casm result_ty)
- = mapNF_Tc substExpr args `thenNF_Tc` \ new_args ->
- applyTcSubstToTy result_ty `thenNF_Tc` \ new_result_ty ->
- returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
-
-substExpr (SCC label expr)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (SCC label new_expr)
-
-substExpr (Case expr ms)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms ->
- returnNF_Tc (Case new_expr new_ms)
-
-substExpr (ListComp expr quals)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- substQuals quals `thenNF_Tc` \ new_quals ->
- returnNF_Tc (ListComp new_expr new_quals)
-
-substExpr (Let binds expr)
- = applyTcSubstToBinds binds `thenNF_Tc` \ new_binds ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (Let new_binds new_expr)
-
---ExplicitList: not in typechecked exprs
-
-substExpr (ExplicitListOut ty exprs)
- = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitListOut new_ty new_exprs)
-
-substExpr (ExplicitTuple exprs)
- = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitTuple new_exprs)
-
-substExpr (If e1 e2 e3)
- = substExpr e1 `thenNF_Tc` \ new_e1 ->
- substExpr e2 `thenNF_Tc` \ new_e2 ->
- substExpr e3 `thenNF_Tc` \ new_e3 ->
- returnNF_Tc (If new_e1 new_e2 new_e3)
-
-substExpr (ArithSeqOut expr info)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- substArithSeq info `thenNF_Tc` \ new_info ->
- returnNF_Tc (ArithSeqOut new_expr new_info)
-
-substExpr (TyLam tyvars expr)
- = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (TyLam new_tyvars new_expr)
-
-substExpr (TyApp expr tys)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- mapNF_Tc (applyTcSubstToTy) tys `thenNF_Tc` \ new_tys ->
- returnNF_Tc (TyApp new_expr new_tys)
-
-substExpr (DictLam dicts expr)
- = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (DictLam new_dicts new_expr)
-
-substExpr (DictApp expr dicts)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
- returnNF_Tc (DictApp new_expr new_dicts)
-
-substExpr (ClassDictLam dicts methods expr)
- = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
- mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
-
-substExpr (Dictionary dicts methods)
- = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts ->
- mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods ->
- returnNF_Tc (Dictionary new_dicts new_methods)
-
-substExpr (SingleDict name)
- = applyTcSubstToId name `thenNF_Tc` \ new_name ->
- returnNF_Tc (SingleDict new_name)
-
-#ifdef DPH
-
-substExpr (ParallelZF expr quals)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- substParQuals quals `thenNF_Tc` \ new_quals ->
- returnNF_Tc (ParallelZF new_expr new_quals)
-
---substExpr (ExplicitPodIn exprs) :: not in typechecked
-
-substExpr (ExplicitPodOut ty exprs)
- = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitPodOut new_ty new_exprs)
-
-substExpr (ExplicitProcessor exprs expr)
- = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (ExplicitProcessor new_exprs new_expr)
-
-#endif {- Data Parallel Haskell -}
-
--------------------------------------------------------------------------
-substArithSeq :: TypecheckedArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
-
-substArithSeq (From e)
- = substExpr e `thenNF_Tc` \ new_e ->
- returnNF_Tc (From new_e)
-
-substArithSeq (FromThen e1 e2)
- = substExpr e1 `thenNF_Tc` \ new_e1 ->
- substExpr e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (FromThen new_e1 new_e2)
-
-substArithSeq (FromTo e1 e2)
- = substExpr e1 `thenNF_Tc` \ new_e1 ->
- substExpr e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (FromTo new_e1 new_e2)
-
-substArithSeq (FromThenTo e1 e2 e3)
- = substExpr e1 `thenNF_Tc` \ new_e1 ->
- substExpr e2 `thenNF_Tc` \ new_e2 ->
- substExpr e3 `thenNF_Tc` \ new_e3 ->
- returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
-
--------------------------------------------------------------------------
-substQuals :: [TypecheckedQual] -> NF_TcM [TypecheckedQual]
-
-substQuals quals
- = mapNF_Tc subst_qual quals
- where
- subst_qual (GeneratorQual pat expr)
- = substPat pat `thenNF_Tc` \ new_pat ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (GeneratorQual new_pat new_expr)
-
- subst_qual (FilterQual expr)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (FilterQual new_expr)
-
--------------------------------------------------------------------------
-#ifdef DPH
-substParQuals :: TypecheckedParQuals -> NF_TcM TypecheckedParQuals
-
-substParQuals (AndParQuals quals1 quals2)
- = substParQuals quals1 `thenNF_Tc` \ new_quals1 ->
- substParQuals quals2 `thenNF_Tc` \ new_quals2 ->
- returnNF_Tc (AndParQuals new_quals1 new_quals2)
-
---substParQuals (DrawnGenIn pats pat expr) :: not in typechecked
-
-substParQuals (DrawnGenOut pats convs pat expr)
- = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
- mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs ->
- substPat pat `thenNF_Tc` \ new_pat ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (DrawnGenOut new_pats new_convs new_pat new_expr)
-
-substParQuals (IndexGen pats pat expr)
- = mapNF_Tc substExpr pats `thenNF_Tc` \ new_pats ->
- substPat pat `thenNF_Tc` \ new_pat ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (IndexGen new_pats new_pat new_expr)
-
-substParQuals (ParFilter expr)
- = substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (ParFilter new_expr)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-Pats]{Patterns}
-%* *
-%************************************************************************
-
-\begin{code}
-substPat :: TypecheckedPat -> NF_TcM TypecheckedPat
-
-substPat (WildPat ty)
- = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (WildPat new_ty)
-
-substPat (VarPat v)
- = applyTcSubstToId v `thenNF_Tc` \ new_v ->
- returnNF_Tc (VarPat new_v)
-
-substPat (LazyPat pat)
- = substPat pat `thenNF_Tc` \ new_pat ->
- returnNF_Tc (LazyPat new_pat)
-
-substPat (AsPat n pat)
- = applyTcSubstToId n `thenNF_Tc` \ new_n ->
- substPat pat `thenNF_Tc` \ new_pat ->
- returnNF_Tc (AsPat new_n new_pat)
-
-substPat (ConPat n ty pats)
- = applyTcSubstToId n `thenNF_Tc` \ new_n ->
- -- ToDo: "n"'s global, so omit?
- applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
- returnNF_Tc (ConPat new_n new_ty new_pats)
-
-substPat (ConOpPat pat1 op pat2 ty)
- = substPat pat1 `thenNF_Tc` \ new_pat1 ->
- applyTcSubstToId op `thenNF_Tc` \ new_op ->
- substPat pat2 `thenNF_Tc` \ new_pat2 ->
- applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (ConOpPat new_pat1 new_op new_pat2 new_ty)
-
-substPat (ListPat ty pats)
- = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
- returnNF_Tc (ListPat new_ty new_pats)
-
-substPat (TuplePat pats)
- = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
- returnNF_Tc (TuplePat new_pats)
-
-substPat (LitPat lit ty)
- = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (LitPat lit new_ty)
-
-substPat (NPat lit ty expr)
- = applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- substExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (NPat lit new_ty new_expr)
-
-substPat (NPlusKPat n k ty e1 e2 e3)
- = applyTcSubstToId n `thenNF_Tc` \ new_n ->
- applyTcSubstToTy ty `thenNF_Tc` \ new_ty ->
- substExpr e1 `thenNF_Tc` \ new_e1 ->
- substExpr e2 `thenNF_Tc` \ new_e2 ->
- substExpr e3 `thenNF_Tc` \ new_e3 ->
- returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2 new_e3)
-
-#ifdef DPH
-substPat (ProcessorPat pats convs pat)
- = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats ->
- mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs ->
- substPat pat `thenNF_Tc` \ new_pat ->
- returnNF_Tc (ProcessorPat new_pats new_convs new_pat)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-TyVar]{Running a substitution over type variables}
-%* *
-%************************************************************************
-
-The type variables in an @AbsBinds@ or @TyLam@ may have a binding in the
-substitution as a result of a @matchTy@ call. So we should subsitute for
-them too. The result should certainly be a type variable.
-
-\begin{code}
-subst_tyvars tyvars
- = mapNF_Tc applyTcSubstToTyVar tyvars `thenNF_Tc` \ new_tyvar_tys ->
- returnNF_Tc (map (getTyVar "subst_tyvars") new_tyvar_tys)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Disambig where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import Id(Id)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-import Unique(Unique, UniqueSupply)
-data Bag a
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Inst
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data SrcLoc
-data Subst
-data TcResult a
-data UniqueSupply
-disambiguateDicts :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1995
-%
-%************************************************************************
-%* *
-\section[Disambig]{Disambiguation of overloading}
-%* *
-%************************************************************************
-
-\begin{code}
-#include "HsVersions.h"
-
-module Disambig (
- disambiguateDicts,
-
- -- and for self-sufficiency...
- Inst, Subst, UniqueSupply, Bag, Error(..), SrcLoc,
- TcResult, Pretty(..), PprStyle, PrettyRep
- ) where
-
-import TcMonad
-import AbsSyn
-
-import AbsPrel ( intTyCon, intTy, {-ToDo:?voidTy,-} doubleTyCon )
-import AbsUniType ( applyTyCon, getTyVar, cmpTyVar, getClassKey,
- isNumericClass, isStandardClass
- )
-import Errors ( ambigErr, defaultErr, Error(..), UnifyErrContext(..) )
-import Id ( Id, DictVar(..) )
-import Inst --( Inst(..), InstOrigin(..), OverloadedLit )
-import InstEnv ( lookupClassInstAtSimpleType )
-import Maybes ( Maybe(..), firstJust )
-import SrcLoc ( mkUnknownSrcLoc )
-import TcSimplify ( tcSimplifyCheckThetas )
-import Unique ( cReturnableClassKey )
-import Util
-\end{code}
-
-If a dictionary constrains a type variable which is
-\begin{itemize}
-\item
-not mentioned in the environment
-\item
-and not mentioned in the type of the expression
-\end{itemize}
-then it is ambiguous. No further information will arise to instantiate
-the type variable; nor will it be generalised and turned into an extra
-parameter to a function.
-
-It is an error for this to occur, except that Haskell provided for
-certain rules to be applied in the special case of numeric types.
-
-Specifically, if
-\begin{itemize}
-\item
-at least one of its classes is a numeric class, and
-\item
-all of its classes are numeric or standard
-\end{itemize}
-then the type variable can be defaulted to the first type in the
-default-type list which is an instance of all the offending classes.
-
-So here is the function which does the work. It takes the ambiguous
-dictionaries and either resolves them (producing bindings) or
-complains. It works by splitting the dictionary list by type
-variable, and using @disambigOne@ to do the real business.
-
-IMPORTANT: @disambiguate@ assumes that its argument dictionaries
-constrain only a simple type variable.
-
-\begin{code}
-type SimpleDictInfo = (Inst, Class, TyVar)
-
-disambiguateDicts :: [Inst] -> TcM ()
-
-disambiguateDicts insts
- = mapTc disambigOne inst_infos `thenTc` \ binds_lists ->
- returnTc ()
- where
- inst_infos = equivClasses cmp_tyvars (map mk_inst_info insts)
- (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmpTyVar` tv2
-
- mk_inst_info dict@(Dict _ clas ty _)
- = (dict, clas, getTyVar "disambiguateDicts" ty)
-\end{code}
-
-@disambigOne@ assumes that its arguments dictionaries constrain all
-the same type variable.
-
-ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
-@()@ instead of @Int@. I reckon this is the Right Thing to do since
-the most common use of defaulting is code like:
-\begin{verbatim}
- _ccall_ foo `seqPrimIO` bar
-\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).
-
-\begin{code}
-disambigOne :: [SimpleDictInfo] -> TcM ()
-
-disambigOne dict_infos
- | isCReturnable dict_infos
- -- C-returnable; just default to Void
- = extendSubstTc tyvar intTy{-ToDo:voidTy-} (AmbigDictCtxt dicts)
-
- | not (isStandardNumericDefaultable dict_infos)
- = failTc (ambigErr dicts) -- no default
-
- | otherwise -- isStandardNumericDefaultable dict_infos
- = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
- -- SO, TRY DEFAULT TYPES IN ORDER
-
- -- Failure here is caused by there being no type in the
- -- default list which can satisfy all the ambiguous classes.
- -- For example, if Real a is reqd, but the only type in the
- -- default list is Int.
- getDefaultingTys `thenNF_Tc` \ default_tys ->
-
- mapNF_Tc try_default default_tys `thenNF_Tc` \ maybe_tys ->
-
- checkMaybeTc (firstJust maybe_tys)
- (defaultErr dicts default_tys)
- `thenTc` \ chosen_default_ty ->
-
- -- SUCCESS; COMBINE TO A BINDS, AND EXTEND SUBSTITUTION
- extendSubstTc tyvar chosen_default_ty (AmbigDictCtxt dicts)
-
- where
- (_,_,tyvar) = head dict_infos -- Should be non-empty
- dicts = [dict | (dict,_,_) <- dict_infos]
-
- try_default :: UniType -> NF_TcM (Maybe UniType)
-
- try_default default_ty
- = let
- thetas = [(clas, default_ty) | (_,clas,_) <- dict_infos]
- in
- recoverQuietlyTc Nothing ( -- if tcSimplify hates us, we get the Nothing
-
- tcSimplifyCheckThetas (DefaultDeclOrigin mkUnknownSrcLoc) thetas `thenTc` \ _ ->
- returnTc (Just default_ty)
- )
-\end{code}
-
-@isStandardNumericDefaultable@ sees whether the dicts have the
-property required for defaulting; namely at least one is numeric, and
-all are standard.
-
-\begin{code}
-isCReturnable, isStandardNumericDefaultable :: [SimpleDictInfo] -> Bool
-
-isStandardNumericDefaultable dict_infos
- = (any (\ (_,c,_) -> isNumericClass c) dict_infos)
- && (all (\ (_,c,_) -> isStandardClass c) dict_infos)
-
-isCReturnable [(_,c,_)] = getClassKey c == cReturnableClassKey
-isCReturnable _ = False -- duplicates will have been removed,
- -- so we don't have to worry about
- -- multiple copies of cReturnableClassKey...
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface GenSpecEtc where
-import Bag(Bag)
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import ErrUtils(Error(..))
-import ErrsTc(UnifyErrContext)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsExpr(Expr)
-import HsLit(Literal)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import LIE(LIE)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import SimplEnv(UnfoldingGuidance)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique, UniqueSupply)
-data Bag a
-data E
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Bind a b
-data Binds a b
-data TypecheckedPat
-data Id
-data Inst
-data LIE
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data SignatureInfo = TySigInfo Id [TyVar] [Inst] UniType SrcLoc | ValSpecInfo Name UniType (Labda Name) SrcLoc | ValInlineInfo Name UnfoldingGuidance SrcLoc | ValDeforestInfo Name SrcLoc | ValMagicUnfoldingInfo Name _PackedString SrcLoc
-data SrcLoc
-data Subst
-data TcResult a
-data TyVar
-data UniType
-data UniqueSupply
-checkSigTyVars :: [TyVar] -> [TyVar] -> UniType -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [TyVar]
-genBinds :: Bool -> E -> Bind Id TypecheckedPat -> LIE -> [(Name, Id)] -> [SignatureInfo] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Binds Id TypecheckedPat, LIE, [(Name, Id)])
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[GenSpecEtc]{Code for GEN, SPEC, PRED, and REL}
#include "HsVersions.h"
module GenSpecEtc (
- genBinds, SignatureInfo(..),
- checkSigTyVars,
-
- -- and to make the interface self-sufficient...
- Bag, E, Bind, Binds, TypecheckedPat, Id, Inst,
- LIE, TcResult, Name, SrcLoc, Subst, TyVar, UniType,
- UniqueSupply, Error(..), Pretty(..), PprStyle,
- PrettyRep
+ TcSigInfo(..),
+ genBinds,
+ checkSigTyVars, checkSigTyVarsGivenGlobals,
+ specTy
) where
-import TcMonad -- typechecker monadery
-import TcMonadFns ( applyTcSubstAndCollectTyVars,
- mkIdsWithGivenTys
- )
-import AbsSyn
-
-import AbsUniType
-import E ( tvOfE, E, LVE(..), TCE(..), UniqFM, CE(..) )
- -- TCE and CE for pragmas only
-import Errors
-import Id ( getIdUniType, mkInstId, Id, DictVar(..) )
-import IdInfo
-import Inst
-import LIE ( mkLIE, unMkLIE, LIE )
+import Ubiq
+
+import TcMonad
+import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
+ newDicts, tyVarsOfInst, instToId )
+import TcEnv ( tcGetGlobalTyVars, newMonoIds )
+import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals )
+import TcType ( TcType(..), TcThetaType(..), TcTauType(..),
+ TcTyVarSet(..), TcTyVar(..), tcInstType, zonkTcType )
+
+import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..),
+ Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake,
+ collectBinders )
+import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..) )
+
+import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag )
+import Class ( GenClass )
+import Id ( GenId, Id(..), mkUserId, idType )
import ListSetOps ( minusList, unionLists, intersectLists )
-import Maybes ( assocMaybe, Maybe(..) )
-import Name ( Name(..) ) -- ToDo: a HACK
-import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
+import Maybes ( Maybe(..), allMaybes )
+import Outputable ( interppSP, interpp'SP )
+import Pretty
+import PprType ( GenClass, GenType, GenTyVar )
+import Type ( mkTyVarTy, splitSigmaTy, mkForAllTys, mkFunTys,
+ getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta )
+import TyVar ( GenTyVar, TyVar(..), minusTyVarSet, emptyTyVarSet,
+ elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
+import Usage ( UVar(..) )
+import Unique ( Unique )
import Util
-
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty --
\end{code}
%************************************************************************
%* *
-\subsection[Gen-SignatureInfo]{The @SignatureInfo@ type}
+\subsection[Gen-SignatureInfo]{The @TcSigInfo@ type}
%* *
%************************************************************************
A type signature (or user-pragma) is typechecked to produce a
-@SignatureInfo@.
+@TcSigInfo@. It contains @TcTypes@ because they are unified with
+the variable's type, and after that checked to see whether they've
+been instantiated.
\begin{code}
-data SignatureInfo
- = TySigInfo Id -- for this value...
- [TyVar] [Inst] TauType
- SrcLoc
-
- | ValSpecInfo Name -- we'd rather have the Name than Id...
- UniType
- (Maybe Name)
- SrcLoc
-
- | ValInlineInfo Name
- UnfoldingGuidance
- SrcLoc
-
- | ValDeforestInfo Name
- SrcLoc
-
- | ValMagicUnfoldingInfo
- Name
- FAST_STRING
+data TcSigInfo s
+ = TySigInfo (TcIdBndr s) -- for this value...
+ [TcTyVar s] (TcThetaType s) (TcTauType s)
SrcLoc
-
- -- ToDo: perhaps add more (for other user pragmas)
\end{code}
%************************************************************************
\begin{code}
-genBinds :: Bool -- True <=> top level
- -> E
- -> TypecheckedBind
- -> LIE -- LIE from typecheck of binds
- -> LVE -- Local types
- -> [SignatureInfo] -- Signatures, if any
- -> TcM (TypecheckedBinds, LIE, LVE) -- Generalised binds, reduced LIE,
- -- polymorphic LVE
- -- The LVE and LIE are fixed points
- -- of the substitution
+genBinds :: [Name] -- Binders
+ -> [TcIdBndr s] -- Monomorphic binders
+ -> TcBind s -- Type-checked monobind
+ -> LIE s -- LIE from typecheck of binds
+ -> [TcSigInfo s] -- Signatures, if any
+ -> (Name -> PragmaInfo) -- Gives pragma info for binder
+ -> TcM s (TcHsBinds s, LIE s, [TcIdBndr s])
\end{code}
In the call $(@genBinds@~env~bind~lie~lve)$, $(bind,lie,lve)$
\end{itemize}
\begin{code}
-genBinds top_level e bind lie lve sigs
- = getSrcLocTc `thenNF_Tc` \ locn ->
-
- -- GET TYPE VARIABLES FREE IN ENV
- applyTcSubstAndCollectTyVars (tvOfE e) `thenNF_Tc` \ free_tyvars ->
-
- -- CHECK THAT THE SIGNATURES MATCH
+genBinds binder_names mono_ids bind lie sig_infos prag_info_fn
+ = -- CHECK THAT THE SIGNATURES MATCH
-- Doesn't affect substitution
- mapTc (checkSigMatch free_tyvars) sigs `thenTc_`
-
- -- UNPACK THE LVE
- let
- (bound_var_names, bound_var_locals) = unzip lve
- bound_var_types = map getIdUniType bound_var_locals
- in
- applyTcSubstToTys bound_var_types `thenNF_Tc` \ bound_var_types' ->
+ mapTc checkSigMatch sig_infos `thenTc_`
+
+ -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE IDENTICAL
+ -- The type signatures on a mutually-recursive group of definitions
+ -- must all have the same context (or none).
+ -- We have to zonk them first to make their type variables line up
+ mapNF_Tc get_zonked_theta sig_infos `thenNF_Tc` \ thetas ->
+ checkTc (null thetas || all (eqSimpleTheta (head thetas)) (tail thetas))
+ (sigContextsErr sig_infos) `thenTc_`
+
+ -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
+ mapNF_Tc (zonkTcType . idType) mono_ids `thenNF_Tc` \ mono_id_types ->
+ tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
let
- mentioned_tyvars' = extractTyVarsFromTys bound_var_types'
-
- -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
- tyvars_to_gen = mentioned_tyvars' `minusList` free_tyvars
-
- -- UNSCRAMBLE "sigs" INTO VARIOUS FLAVOURS
- -- AND SNAFFLE ANY "IdInfos" FOR VARS HERE
-
- (ty_sigs, upragmas) = partition is_tysig_info sigs
- inline_sigs = filter is_inline_info upragmas
- deforest_sigs = filter is_deforest_info upragmas
- magic_uf_sigs = filter is_magic_uf_info upragmas
- spec_sigs = filter is_spec_info upragmas
-
- unfold_me_fn n
- = case [ x | x@(ValInlineInfo v _ _) <- inline_sigs, v == n ] of
- (ValInlineInfo _ guide _ :_) -> iWantToBeINLINEd guide
- [] ->
- case [ x | x@(ValMagicUnfoldingInfo v _ _) <- magic_uf_sigs, v == n ] of
- (ValMagicUnfoldingInfo _ str _:_) -> mkMagicUnfolding str
- [] -> noInfo_UF
-
- deforest_me_fn n
- = case [ x | x@(ValDeforestInfo v _) <- deforest_sigs, v == n ] of
- (ValDeforestInfo _ _ : _) -> DoDeforest
- [] -> Don'tDeforest
-
- id_info_for n
- = noIdInfo
- `addInfo_UF` (unfold_me_fn n)
- `addInfo` (deforest_me_fn n)
-
- id_infos = [ id_info_for n | n <- bound_var_names ]
+ mentioned_tyvars = tyVarsOfTypes mono_id_types
+ tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars
in
- resolveOverloading top_level e free_tyvars tyvars_to_gen lie bind ty_sigs
+
+ -- DEAL WITH OVERLOADING
+ resolveOverloading tyvars_to_gen lie bind sig_infos
`thenTc` \ (lie', reduced_tyvars_to_gen, dict_binds, dicts_bound) ->
-- BUILD THE NEW LOCALS
let
- dict_tys = map getInstUniType dicts_bound
-
- envs_and_new_locals_types
- = map (quantifyTy reduced_tyvars_to_gen . glueTyArgs dict_tys) bound_var_types'
-
- (_, new_locals_types) = unzip envs_and_new_locals_types
- in
- -- The new_locals function is passed into genBinds
- -- so it can generate top-level or non-top-level locals
- let
- lve_of_new_ids = mkIdsWithGivenTys bound_var_names new_locals_types id_infos
- new_ids = map snd lve_of_new_ids
+ tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order
+ dict_tys = [idType d | TcId d <- dicts_bound] -- Slightly ugh-ish
+ poly_tys = map (mkForAllTys tyvars . mkFunTys dict_tys) mono_id_types
+ poly_ids = zipWithEqual mk_poly binder_names poly_tys
+ mk_poly name ty = mkUserId name ty (prag_info_fn name)
in
-- BUILD RESULTS
returnTc (
--- pprTrace "Gen: " (ppSep [ppr PprDebug new_ids,
--- ppStr "; to gen ", ppr PprDebug tyvars_to_gen,
--- ppStr "; reduced ", ppr PprDebug reduced_tyvars_to_gen
--- ]) $
- AbsBinds reduced_tyvars_to_gen (map mkInstId dicts_bound)
- (bound_var_locals `zip` new_ids)
- dict_binds bind,
+ AbsBinds tyvars
+ dicts_bound
+ (map TcId mono_ids `zip` map TcId poly_ids)
+ dict_binds
+ bind,
lie',
- lve_of_new_ids
+ poly_ids
)
- where
- is_tysig_info (TySigInfo _ _ _ _ _) = True
- is_tysig_info _ = False
- is_inline_info (ValInlineInfo _ _ _) = True
- is_inline_info _ = False
-
- is_deforest_info (ValDeforestInfo _ _) = True
- is_deforest_info _ = False
-
- is_magic_uf_info (ValMagicUnfoldingInfo _ _ _) = True
- is_magic_uf_info _ = False
-
- is_spec_info (ValSpecInfo _ _ _ _) = True
- is_spec_info _ = False
+get_zonked_theta (TySigInfo _ _ theta _ _)
+ = mapNF_Tc (\ (c,t) -> zonkTcType t `thenNF_Tc` \ t' -> returnNF_Tc (c,t')) theta
\end{code}
\begin{code}
-resolveOverloading
- :: Bool -- True <=> top level
- -> E
- -> [TyVar] -- Tyvars free in E
- -> [TyVar] -- Tyvars over which we are going to generalise
- -> LIE -- The LIE to deal with
- -> TypecheckedBind -- The binding group
- -> [SignatureInfo] -- And its real type-signature information
- -> TcM (LIE, -- LIE to pass up the way; a fixed point of
- -- the current substitution
- [TyVar], -- Revised tyvars to generalise
- [(Inst, TypecheckedExpr)],-- Dict bindings
- [Inst]) -- List of dicts to bind here
-
-resolveOverloading top_level e free_tyvars tyvars_to_gen lie bind ty_sigs
- = let
- dicts = unMkLIE lie
- in
- -- DEAL WITH MONOMORPHISM RESTRICTION
- if (not (isUnRestrictedGroup tysig_vars bind)) then
-
- -- Restricted group, so bind no dictionaries, and
+resolveOverloading
+ :: TcTyVarSet s -- Tyvars over which we are going to generalise
+ -> LIE s -- The LIE to deal with
+ -> TcBind s -- The binding group
+ -> [TcSigInfo s] -- And its real type-signature information
+ -> TcM s (LIE s, -- LIE to pass up the way; a fixed point of
+ -- the current substitution
+ TcTyVarSet s, -- Revised tyvars to generalise
+ [(TcIdOcc s, TcExpr s)], -- Dict bindings
+ [TcIdOcc s]) -- List of dicts to bind here
+
+resolveOverloading tyvars_to_gen dicts bind ty_sigs
+ | not (isUnRestrictedGroup tysig_vars bind)
+ = -- Restricted group, so bind no dictionaries, and
-- remove from tyvars_to_gen any constrained type variables
-- *Don't* simplify dicts at this point, because we aren't going
-- we'll know that the literals are all Ints, and we can just produce
-- Int literals!
- -- Find all the type variables involved in overloading
+ -- Find all the type variables involved in overloading, the "constrained_tyvars"
-- These are the ones we *aren't* going to generalise.
-- We must be careful about doing this:
-- (a) If we fail to generalise a tyvar which is not actually
- -- constrained, then it will never, ever get bound, and lands
+ -- constrained, then it will never, ever get bound, and lands
-- up printed out in interface files! Notorious example:
-- instance Eq a => Eq (Foo a b) where ..
-- Here, b is not constrained, even though it looks as if it is.
-- the LIE, whose type might very well involve non-overloaded
-- type variables.
-- (b) On the other hand, we mustn't generalise tyvars which are constrained,
- -- because we are going to pass on out the unmodified LIE, with those
+ -- because we are going to pass on out the unmodified LIE, with those
-- tyvars in it. They won't be in scope if we've generalised them.
--
-- So we are careful, and do a complete simplification just to find the
-- constrained tyvars. We don't use any of the results, except to
-- find which tyvars are constrained.
- tcSimplify top_level free_tyvars tyvars_to_gen dicts
- `thenTc` \ (_, _, dicts_sig) ->
-
--- ASSERT: tcSimplify has already applied subst to its results
--- (WDP/SLPJ 95/07)
--- applyTcSubstToInsts dicts_sig `thenNF_Tc` \ dicts_sig' ->
+ tcSimplify tyvars_to_gen dicts `thenTc` \ (_, _, dicts_sig) ->
let
- constrained_tyvars
- = foldr (unionLists . extractTyVarsFromInst) [] dicts_sig
-
- reduced_tyvars_to_gen = tyvars_to_gen `minusList` constrained_tyvars
-
- increased_free_tyvars = free_tyvars `unionLists` constrained_tyvars
+ -- ASSERT: dicts_sig is already zonked!
+ constrained_tyvars = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet dicts_sig
+ reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
in
- -- Do it again, but with increased_free_tyvars/reduced_tyvars_to_gen:
-
- tcSimplify top_level increased_free_tyvars reduced_tyvars_to_gen dicts
+ -- Do it again, but with increased free_tyvars/reduced_tyvars_to_gen:
+ -- We still need to do this simplification, because some dictionaries
+ -- may gratuitouslyconstrain some tyvars over which we *are* going
+ -- to generalise.
+ -- For example d::Eq (Foo a b), where Foo is instanced as above.
+ tcSimplifyWithExtraGlobals constrained_tyvars reduced_tyvars_to_gen dicts
`thenTc` \ (dicts_free, dicts_binds, dicts_sig2) ->
---NB: still no applyTcSubstToInsts
+ ASSERT(isEmptyBag dicts_sig2)
--- pprTrace "resolve:" (ppCat [ppr PprDebug free_tyvars, ppr PprDebug tyvars_to_gen, ppr PprDebug constrained_tyvars, ppr PprDebug reduced_tyvars_to_gen, ppr PprDebug bind]) $
- returnTc (mkLIE (dicts_free++dicts_sig2), -- All these are left unbound
- reduced_tyvars_to_gen,
+ returnTc (dicts_free, -- All these are left unbound
+ reduced_tyvars_to_gen,
dicts_binds, -- Local dict binds
[]) -- No lambda-bound dicts
-- The returned LIE should be a fixed point of the substitution
- else -- Unrestricted group
- case ty_sigs of
- [] -> -- NO TYPE SIGNATURES
+ | otherwise -- An unrestricted group
+ = case ty_sigs of
+ [] -> -- NO TYPE SIGNATURES
- tcSimplify top_level free_tyvars tyvars_to_gen dicts
- `thenTc` \ (dicts_free, dict_binds, dicts_sig) ->
- returnTc (mkLIE dicts_free, tyvars_to_gen, dict_binds, dicts_sig)
+ tcSimplify tyvars_to_gen dicts `thenTc` \ (dicts_free, dict_binds, dicts_sig) ->
+ returnTc (dicts_free, tyvars_to_gen, dict_binds,
+ map instToId (bagToList dicts_sig))
- other -> -- TYPE SIGNATURES PRESENT!
+ (TySigInfo _ _ theta _ _ : other) -> -- TYPE SIGNATURES PRESENT!
- -- Check that all the signature contexts are identical
- -- "tysig_dicts_s" is a list (one for each id declared
- -- in this group) of lists of dicts (the list
- -- corresponds to the context in the sig).
- -- "dicts_sig" is just the first such list; we match
- -- it against all the others.
+ tcAddErrCtxt (sigsCtxt tysig_vars) $
- mapNF_Tc applyTcSubstToInsts tysig_dicts_s
- `thenNF_Tc` \ (dicts_sig : other_dicts_s) ->
-
- checkTc (not (all (same_dicts dicts_sig) other_dicts_s))
- -- The type signatures on a mutually-recursive group of definitions
- -- must all have the same context (or none). See Errors.lhs.
- (sigContextsErr ty_sigs) `thenTc_`
+ newDicts SignatureOrigin theta `thenNF_Tc` \ (dicts_sig, dict_ids) ->
-- Check that the needed dicts can be expressed in
-- terms of the signature ones
tcSimplifyAndCheck
- top_level
- free_tyvars -- Vars free in the environment
tyvars_to_gen -- Type vars over which we will quantify
dicts_sig -- Available dicts
dicts -- Want bindings for these dicts
- (BindSigCtxt tysig_vars)
`thenTc` \ (dicts_free, dict_binds) ->
- returnTc (mkLIE dicts_free, tyvars_to_gen, dict_binds, dicts_sig)
+ returnTc (dicts_free, tyvars_to_gen, dict_binds, dict_ids)
where
- tysig_dicts_s = [dicts | (TySigInfo _ _ dicts _ _) <- ty_sigs]
- tysig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs]
-
- -- same_dicts checks that (post substitution) all the type signatures
- -- constrain the same type variables in the same way
- same_dicts [] [] = True
- same_dicts [] _ = False
- same_dicts _ [] = False
- same_dicts (d1:d1s) (d2:d2s) = matchesInst d1 d2 && same_dicts d1s d2s
-
- -- don't use the old version, because zipWith will truncate
- -- the longer one!
- --OLD: same_dicts dicts1 dicts2 = and (zipWith matchesInst dicts1 dicts2)
+ tysig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs]
\end{code}
@checkSigMatch@ does the next step in checking signature matching.
now (ToDo).
\begin{code}
-checkSigMatch :: [TyVar] -- Free in environment
- -> SignatureInfo
- -> TcM [TyVar]
-
-checkSigMatch env_tyvars (TySigInfo name sig_tyvars _ tau_ty src_loc)
- = let
- inferred_ty = getIdUniType name
- in
- addSrcLocTc src_loc (
- checkSigTyVars env_tyvars sig_tyvars tau_ty inferred_ty
- (SigCtxt name tau_ty)
- )
+checkSigMatch :: TcSigInfo s -> TcM s [TcTyVar s]
-checkSigMatch _ other_not_really_a_sig = returnTc []
+checkSigMatch (TySigInfo id sig_tyvars _ tau_ty src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (sigCtxt id) $
+ checkSigTyVars sig_tyvars tau_ty (idType id)
\end{code}
Not exported:
\begin{code}
-isUnRestrictedGroup :: [Id] -- Signatures given for these
- -> TypecheckedBind
- -> Bool
+isUnRestrictedGroup :: [TcIdBndr s] -- Signatures given for these
+ -> TcBind s
+ -> Bool
isUnRestrictedGroup sigs EmptyBind = True
isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds
isUnRestrictedGroup sigs (RecBind monobinds) = isUnResMono sigs monobinds
-is_elem = isIn "isUnResMono"
+is_elem v vs = isIn "isUnResMono" v vs
-isUnResMono sigs EmptyMonoBinds = True
-isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 && isUnResMono sigs mb2
-isUnResMono sigs (PatMonoBind (VarPat v) _ _) = v `is_elem` sigs
-isUnResMono sigs (PatMonoBind other _ _) = False
-isUnResMono sigs (VarMonoBind v _) = v `is_elem` sigs
-isUnResMono sigs (FunMonoBind _ _ _) = True
+isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _) = v `is_elem` sigs
+isUnResMono sigs (PatMonoBind other _ _) = False
+isUnResMono sigs (VarMonoBind (TcId v) _) = v `is_elem` sigs
+isUnResMono sigs (FunMonoBind _ _ _) = True
+isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 &&
+ isUnResMono sigs mb2
+isUnResMono sigs EmptyMonoBinds = True
\end{code}
@checkSigTyVars@ is used after the type in a type signature has been unified with
the actual type found. It then checks that the type variables of the type signature
-are
+are
(a) still all type variables
eg matching signature [a] against inferred type [(p,q)]
[then a will be unified to a non-type variable]
g x = ... where
f :: a->[a]
f y = [x,y]
-
+
Here, f is forced to be monorphic by the free occurence of x.
Before doing this, the substitution is applied to the signature type variable.
-It's {\em assumed} that the substitution has already been applied to the
-environment type variables.
-
\begin{code}
-checkSigTyVars :: [TyVar] -- Tyvars free in environment;
- -- fixed points of substitution
- -> [TyVar] -- The original signature type variables
- -> UniType -- signature type (for err msg)
- -> UniType -- inferred type (for err msg)
- -> UnifyErrContext -- also for error msg
- -> TcM [TyVar] -- Post-substitution signature type variables
-
-checkSigTyVars env_tyvars sig_tyvars sig_tau inferred_tau err_ctxt
- = getSrcLocTc `thenNF_Tc` \ locn ->
- applyTcSubstToTy inferred_tau `thenNF_Tc` \ inferred_tau' ->
- let
- match_err = badMatchErr sig_tau inferred_tau' err_ctxt locn
- in
- applyTcSubstToTyVars sig_tyvars `thenNF_Tc` \ sig_tys ->
-
- -- Check point (a) above
- checkMaybesTc (map getTyVarMaybe sig_tys) match_err `thenTc` \ sig_tyvars' ->
+checkSigTyVars :: [TcTyVar s] -- The original signature type variables
+ -> TcType s -- signature type (for err msg)
+ -> TcType s -- inferred type (for err msg)
+ -> TcM s [TcTyVar s] -- Post-substitution signature type variables
+
+checkSigTyVars sig_tyvars sig_tau inferred_tau
+ = tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
+ checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_tau inferred_tau
+
+checkSigTyVarsGivenGlobals
+ :: TcTyVarSet s -- Consider these fully-zonked tyvars as global
+ -> [TcTyVar s] -- The original signature type variables
+ -> TcType s -- signature type (for err msg)
+ -> TcType s -- inferred type (for err msg)
+ -> TcM s [TcTyVar s] -- Post-substitution signature type variables
+
+checkSigTyVarsGivenGlobals globals sig_tyvars sig_tau inferred_tau
+ = -- Check point (a) above
+ mapNF_Tc (zonkTcType.mkTyVarTy) sig_tyvars `thenNF_Tc` \ sig_tys ->
+ checkMaybeTcM (allMaybes (map getTyVar_maybe sig_tys)) match_err `thenTc` \ sig_tyvars' ->
-- Check point (b)
- checkTc (not (hasNoDups sig_tyvars')) match_err `thenTc_`
+ checkTcM (hasNoDups sig_tyvars') match_err `thenTc_`
-- Check point (c)
- -- We want to report errors in terms of the original signature tyvars,
+ -- 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.
let
- is_elem = isIn "checkSigTyVars"
-
- mono_tyvars = [ sig_tyvar
+ mono_tyvars = [ sig_tyvar
| (sig_tyvar,sig_tyvar') <- zipEqual sig_tyvars sig_tyvars',
- sig_tyvar' `is_elem` env_tyvars
+ sig_tyvar' `elementOfTyVarSet` globals
]
in
- checkTc (not (null mono_tyvars))
- (notAsPolyAsSigErr sig_tau mono_tyvars err_ctxt locn) `thenTc_`
+ checkTc (null mono_tyvars)
+ (notAsPolyAsSigErr sig_tau mono_tyvars) `thenTc_`
returnTc sig_tyvars'
+ where
+ match_err = zonkTcType inferred_tau `thenNF_Tc` \ inferred_tau' ->
+ failTc (badMatchErr sig_tau inferred_tau')
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[GenEtc-SpecTy]{Instantiate a type and create new dicts for it}
+%* *
+%************************************************************************
+
+\begin{code}
+specTy :: InstOrigin s
+ -> Type
+ -> NF_TcM s ([TcTyVar s], LIE s, TcType s, [TcIdOcc s])
+
+specTy origin sigma_ty
+ = tcInstType [] sigma_ty `thenNF_Tc` \ tc_sigma_ty ->
+ let
+ (tyvars, theta, tau) = splitSigmaTy tc_sigma_ty
+ in
+ -- Instantiate the dictionary types
+ newDicts origin theta `thenNF_Tc` \ (dicts, dict_ids) ->
+
+ -- Return the list of tyvars, the list of dicts and the tau type
+ returnNF_Tc (tyvars, dicts, tau, dict_ids)
+\end{code}
+
+
+
+Contexts and errors
+~~~~~~~~~~~~~~~~~~~
+\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),
+ ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction"
+ ])
+\end{code}
+
+
+\begin{code}
+badMatchErr sig_ty inferred_ty sty
+ = ppHang (ppStr "Type signature doesn't match inferred type")
+ 4 (ppAboves [ppHang (ppStr "Signature:") 4 (ppr sty sig_ty),
+ ppHang (ppStr "Inferred :") 4 (ppr sty inferred_ty)
+ ])
+
+sigCtxt id sty
+ = ppSep [ppStr "When checking signature for", ppr sty id]
+sigsCtxt ids sty
+ = ppSep [ppStr "When checking signature(s) for:", interpp'SP sty ids]
+\end{code}
+
+
+\begin{code}
+sigContextsErr ty_sigs sty
+ = ppHang (ppStr "A group of type signatures have mismatched contexts")
+ 4 (ppAboves (map ppr_sig_info ty_sigs))
+ where
+ ppr_sig_info (TySigInfo val tyvars theta tau_ty _)
+ = ppHang (ppBeside (ppr sty val) (ppStr " :: "))
+ 4 (if null theta
+ then ppNil
+ else ppBesides [ppStr "(",
+ ppIntersperse (ppStr ", ") (map (ppr_inst sty) theta),
+ ppStr ") => ..."])
+ ppr_inst sty (clas, ty) = ppCat [ppr sty clas, ppr sty ty]
\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[Inst]{The @Inst@ type: dictionaries or method instances}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Inst (
+ Inst(..), -- Visible only to TcSimplify
+
+ InstOrigin(..), OverloadedLit(..),
+ LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
+
+ InstanceMapper(..),
+
+ newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
+
+ instType, tyVarsOfInst, lookupInst,
+
+ isDict, isTyVarDict,
+
+ zonkInst, instToId,
+
+ matchesInst,
+ instBindingRequired, instCanBeGeneralised
+
+ ) where
+
+import 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 )
+
+import TcMonad
+import TcEnv ( tcLookupGlobalValueByKey )
+import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
+ tcInstType, tcInstTcType, zonkTcType )
+
+import Bag ( Bag, emptyBag, unitBag, unionBags, listToBag, consBag )
+import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv )
+import Id ( GenId, idType, mkInstId )
+import MatchEnv ( lookupMEnv, insertMEnv )
+import Name ( Name )
+import NameTypes( ShortName, mkShortName )
+import Outputable
+import PprType ( GenClass, TyCon, GenType, GenTyVar )
+import PprStyle ( PprStyle(..) )
+import Pretty
+import SpecEnv ( SpecEnv(..) )
+import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
+import Type ( GenType, eqSimpleTy,
+ isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
+ splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes )
+import TyVar ( GenTyVar )
+import TysPrim ( intPrimTy )
+import TysWiredIn ( intDataCon )
+import Unique ( Unique, showUnique,
+ fromRationalClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey )
+import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic )
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Inst-collections]{LIE: a collection of Insts}
+%* *
+%************************************************************************
+
+\begin{code}
+type LIE s = Bag (Inst s)
+
+emptyLIE = emptyBag
+unitLIE inst = unitBag inst
+plusLIE lie1 lie2 = lie1 `unionBags` lie2
+consLIE inst lie = inst `consBag` lie
+
+zonkLIE :: LIE s -> NF_TcM s (LIE s)
+zonkLIE lie = mapBagNF_Tc zonkInst lie
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Inst-types]{@Inst@ types}
+%* *
+%************************************************************************
+
+An @Inst@ is either a dictionary, an instance of an overloaded
+literal, or an instance of an overloaded value. We call the latter a
+``method'' even though it may not correspond to a class operation.
+For example, we might have an instance of the @double@ function at
+type Int, represented by
+
+ Method 34 doubleId [Int] origin
+
+\begin{code}
+data Inst s
+ = Dict
+ Unique
+ Class -- The type of the dict is (c t), where
+ (TcType s) -- c is the class and t the type;
+ (InstOrigin s)
+ SrcLoc
+
+ | Method
+ Unique
+
+ (TcIdOcc s) -- The overloaded function
+ -- This function will be a global, local, or ClassOpId;
+ -- inside instance decls (only) it can also be an InstId!
+ -- The id needn't be completely polymorphic.
+ -- You'll probably find its name (for documentation purposes)
+ -- inside the InstOrigin
+
+ [TcType s] -- The types to which its polymorphic tyvars
+ -- should be instantiated.
+ -- These types must saturate the Id's foralls.
+
+ (TcRhoType s) -- Cached: (type-of-id applied to inst_tys)
+ -- If this type is (theta => tau) then the type of the Method
+ -- is tau, and the method can be built by saying
+ -- id inst_tys dicts
+ -- where dicts are constructed from theta
+
+ (InstOrigin s)
+ SrcLoc
+
+ | LitInst
+ Unique
+ OverloadedLit
+ (TcType s) -- The type at which the literal is used
+ (InstOrigin s) -- Always a literal; but more convenient to carry this around
+ SrcLoc
+
+data OverloadedLit
+ = OverloadedIntegral Integer -- The number
+ | OverloadedFractional Rational -- The number
+
+getInstOrigin (Dict u clas ty origin loc) = origin
+getInstOrigin (Method u clas ty rho origin loc) = origin
+getInstOrigin (LitInst u lit ty origin loc) = origin
+\end{code}
+
+Construction
+~~~~~~~~~~~~
+
+\begin{code}
+newDicts :: InstOrigin s
+ -> [(Class, TcType s)]
+ -> NF_TcM s (LIE s, [TcIdOcc s])
+newDicts orig theta
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
+ let
+ mk_dict u (clas, ty) = Dict u clas ty orig loc
+ dicts = zipWithEqual mk_dict new_uniqs theta
+ in
+ returnNF_Tc (listToBag dicts, map instToId dicts)
+
+newDictsAtLoc orig loc theta -- Local function, similar to newDicts,
+ -- but with slightly different interface
+ = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
+ let
+ mk_dict u (clas, ty) = Dict u clas ty orig loc
+ dicts = zipWithEqual mk_dict new_uniqs theta
+ in
+ returnNF_Tc (dicts, map instToId dicts)
+
+newMethod :: InstOrigin s
+ -> TcIdOcc s
+ -> [TcType s]
+ -> NF_TcM s (LIE s, TcIdOcc s)
+newMethod orig id tys
+ = -- Get the Id type and instantiate it at the specified types
+ (case id of
+ RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
+ in tcInstType (tyvars `zipEqual` tys) rho
+ TcId id -> let (tyvars, rho) = splitForAllTy (idType id)
+ in tcInstTcType (tyvars `zipEqual` tys) rho
+ ) `thenNF_Tc` \ rho_ty ->
+
+ -- Our friend does the rest
+ newMethodWithGivenTy orig id tys rho_ty
+
+
+newMethodWithGivenTy orig id tys rho_ty
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUnique `thenNF_Tc` \ new_uniq ->
+ let
+ meth_inst = Method new_uniq id tys rho_ty orig loc
+ in
+ returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
+
+newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
+newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
+ -- slightly different interface
+ = -- Get the Id type and instantiate it at the specified types
+ let
+ (tyvars,rho) = splitForAllTy (idType real_id)
+ in
+ tcInstType (tyvars `zipEqual` tys) rho `thenNF_Tc` \ rho_ty ->
+ tcGetUnique `thenNF_Tc` \ new_uniq ->
+ let
+ meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
+ in
+ returnNF_Tc (meth_inst, instToId meth_inst)
+
+newOverloadedLit :: InstOrigin s
+ -> OverloadedLit
+ -> TcType s
+ -> NF_TcM s (LIE s, TcIdOcc s)
+newOverloadedLit orig lit ty
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUnique `thenNF_Tc` \ new_uniq ->
+ let
+ lit_inst = LitInst new_uniq lit ty orig loc
+ in
+ returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
+\end{code}
+
+
+\begin{code}
+instToId :: Inst s -> TcIdOcc s
+instToId (Dict uniq clas ty orig loc)
+ = TcId (mkInstId uniq (mkDictTy clas ty) (mkShortName SLIT("dict") loc))
+instToId (Method uniq id tys rho_ty orig loc)
+ = TcId (mkInstId uniq tau_ty (mkShortName (getOccurrenceName id) loc))
+ where
+ (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type
+instToId (LitInst uniq list ty orig loc)
+ = TcId (mkInstId uniq ty (mkShortName SLIT("lit") loc))
+\end{code}
+
+\begin{code}
+instType :: Inst s -> TcType s
+instType (Dict _ clas ty _ _) = mkDictTy clas ty
+instType (LitInst _ _ ty _ _) = ty
+instType (Method _ id tys ty _ _) = ty
+\end{code}
+
+
+Zonking
+~~~~~~~
+Zonking makes sure that the instance types are fully zonked,
+but doesn't do the same for the Id in a Method. There's no
+need, and it's a lot of extra work.
+
+\begin{code}
+zonkInst :: Inst s -> NF_TcM s (Inst s)
+zonkInst (Dict uniq clas ty orig loc)
+ = zonkTcType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (Dict uniq clas new_ty orig loc)
+
+zonkInst (Method uniq id tys rho orig loc) -- Doesn't zonk the id!
+ = mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys ->
+ zonkTcType rho `thenNF_Tc` \ new_rho ->
+ returnNF_Tc (Method uniq id new_tys new_rho orig loc)
+
+zonkInst (LitInst uniq lit ty orig loc)
+ = zonkTcType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (LitInst uniq lit new_ty orig loc)
+\end{code}
+
+
+\begin{code}
+tyVarsOfInst :: Inst s -> TcTyVarSet s
+tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
+tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys
+tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
+\end{code}
+
+@matchesInst@ checks when two @Inst@s are instances of the same
+thing at the same type, even if their uniques differ.
+
+\begin{code}
+matchesInst :: Inst s -> Inst s -> Bool
+
+matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
+ = clas1 == clas2 && ty1 `eqSimpleTy` ty2
+
+matchesInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
+ = id1 == id2
+ && and (zipWith eqSimpleTy tys1 tys2)
+ && length tys1 == length tys2
+
+matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
+ = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2
+ where
+ (OverloadedIntegral i1) `eq` (OverloadedIntegral i2) = i1 == i2
+ (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2
+ _ `eq` _ = False
+
+matchesInst other1 other2 = False
+\end{code}
+
+
+Predicates
+~~~~~~~~~~
+\begin{code}
+isDict :: Inst s -> Bool
+isDict (Dict _ _ _ _ _) = True
+isDict other = False
+
+isTyVarDict :: Inst s -> Bool
+isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty
+isTyVarDict other = False
+\end{code}
+
+Two predicates which deal with the case where class constraints don't
+necessarily result in bindings. The first tells whether an @Inst@
+must be witnessed by an actual binding; the second tells whether an
+@Inst@ can be generalised over.
+
+\begin{code}
+instBindingRequired :: Inst s -> Bool
+instBindingRequired inst
+ = case getInstOrigin inst of
+ CCallOrigin _ _ -> False -- No binding required
+ LitLitOrigin _ -> False
+ OccurrenceOfCon _ -> False
+ 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
+\end{code}
+
+
+Printing
+~~~~~~~~
+ToDo: improve these pretty-printing things. The ``origin'' is really only
+relevant in error messages.
+
+\begin{code}
+instance Outputable (Inst s) where
+ ppr sty (LitInst uniq lit ty orig loc)
+ = ppHang (ppSep [case lit of
+ OverloadedIntegral i -> ppInteger i
+ OverloadedFractional f -> ppRational f,
+ ppStr "at",
+ ppr sty ty,
+ show_uniq sty uniq
+ ])
+ 4 (show_origin sty orig)
+
+ ppr sty (Dict uniq clas ty orig loc)
+ = ppHang (ppSep [ppr sty clas,
+ ppStr "at",
+ ppr sty ty,
+ show_uniq sty uniq
+ ])
+ 4 (show_origin sty orig)
+
+ ppr sty (Method uniq id tys rho orig loc)
+ = ppHang (ppSep [ppr sty id,
+ ppStr "at",
+ ppr sty tys,
+ show_uniq sty uniq
+ ])
+ 4 (show_origin sty orig)
+
+show_uniq PprDebug uniq = ppr PprDebug uniq
+show_uniq sty uniq = ppNil
+
+show_origin sty orig = ppBesides [ppLparen, pprOrigin sty orig, ppRparen]
+\end{code}
+
+Printing in error messages
+
+\begin{code}
+noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[InstEnv-types]{Type declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
+\end{code}
+
+A @ClassInstEnv@ lives inside a class, and identifies all the instances
+of that class. The @Id@ inside a ClassInstEnv mapping is the dfun for
+that instance.
+
+There is an important consistency constraint between the @MatchEnv@s
+in and the dfun @Id@s inside them: the free type variables of the
+@Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
+type variables of the dfun. Thus, the @ClassInstEnv@ for @Eq@ might
+contain the following entry:
+@
+ [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
+@
+The "a" in the pattern must be one of the forall'd variables in
+the dfun type.
+
+\begin{code}
+lookupInst :: Inst s
+ -> TcM s ([Inst s],
+ (TcIdOcc s, TcExpr s)) -- The new binding
+
+-- Dictionaries
+
+lookupInst dict@(Dict _ clas ty orig loc)
+ = case lookupMEnv matchTy (get_inst_env clas orig) ty of
+ Nothing -> failTc (noInstanceErr dict)
+
+ Just (dfun_id, tenv)
+ -> let
+ (tyvars, rho) = splitForAllTy (idType dfun_id)
+ ty_args = map (assoc "lookupInst" tenv) tyvars
+ -- tenv should bind all the tyvars
+ in
+ tcInstType tenv rho `thenNF_Tc` \ dfun_rho ->
+ let
+ (theta, tau) = splitRhoTy dfun_rho
+ in
+ newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
+ let
+ rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
+ in
+ returnTc (dicts, (instToId dict, rhs))
+
+
+-- Methods
+
+lookupInst inst@(Method _ id tys rho orig loc)
+ = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
+ returnTc (dicts, (instToId inst, mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
+ where
+ (theta,_) = splitRhoTy rho
+
+-- Literals
+
+lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
+ | i >= toInteger minInt && i <= toInteger maxInt
+ = -- It's overloaded but small enough to fit into an Int
+ tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
+ newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
+ returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) int_lit))
+
+ | otherwise
+ = -- 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)))
+ 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 ->
+ 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)))
+\end{code}
+
+There is a second, simpler interface, when you want an instance of a
+class at a given nullary type constructor. It just returns the
+appropriate dictionary if it exists. It is used only when resolving
+ambiguous dictionaries.
+
+\begin{code}
+lookupClassInstAtSimpleType :: Class -> Type -> Maybe Id
+
+lookupClassInstAtSimpleType clas ty
+ = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
+ Nothing -> Nothing
+ Just (dfun,_) -> ASSERT( null tyvars && null theta )
+ Just dfun
+ where
+ (tyvars, theta, _) = splitSigmaTy (idType dfun)
+\end{code}
+
+
+@mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
+It does it by filtering the class's @InstEnv@. All pretty shady stuff.
+
+\begin{code}
+mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
+\end{code}
+
+\begin{pseudocode}
+mkInstSpecEnv :: Class -- class
+ -> Type -- instance type
+ -> [TyVarTemplate] -- instance tyvars
+ -> ThetaType -- superclasses dicts
+ -> SpecEnv -- specenv for dfun of instance
+
+mkInstSpecEnv clas inst_ty inst_tvs inst_theta
+ = mkSpecEnv (catMaybes (map maybe_spec_info matches))
+ where
+ matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty
+
+ maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
+ = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
+ maybe_spec_info (_, match_info, _)
+ = Nothing
+\end{pseudocode}
+
+
+\begin{code}
+addClassInst
+ :: ClassInstEnv -- Incoming envt
+ -> Type -- The instance type: inst_ty
+ -> Id -- Dict fun id to apply. Free tyvars of inst_ty must
+ -- be the same as the forall'd tyvars of the dfun id.
+ -> MaybeErr
+ ClassInstEnv -- Success
+ (Type, Id) -- Offending overlap
+
+addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection[Inst-origin]{The @InstOrigin@ type}
+%* *
+%************************************************************************
+
+The @InstOrigin@ type gives information about where a dictionary came from.
+This is important for decent error message reporting because dictionaries
+don't appear in the original source code. Doubtless this type will evolve...
+
+\begin{code}
+data InstOrigin s
+ = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
+ | OccurrenceOfCon Id -- Occurrence of a data constructor
+
+ | InstanceDeclOrigin -- Typechecking an instance decl
+
+ | LiteralOrigin HsLit -- Occurrence of a literal
+
+ | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
+
+ | SignatureOrigin -- A dict created from a type signature
+
+ | DoOrigin -- The monad for a do expression
+
+ | ClassDeclOrigin -- Manufactured during a class decl
+
+ | DerivingOrigin InstanceMapper
+ Class
+ TyCon
+
+ -- During "deriving" operations we have an ever changing
+ -- mapping of classes to instances, so we record it inside the
+ -- origin information. This is a bit of a hack, but it works
+ -- fine. (Simon is to blame [WDP].)
+
+ | InstanceSpecOrigin InstanceMapper
+ Class -- in a SPECIALIZE instance pragma
+ Type
+
+ -- When specialising instances the instance info attached to
+ -- each class is not yet ready, so we record it inside the
+ -- origin information. This is a bit of a hack, but it works
+ -- fine. (Patrick is to blame [WDP].)
+
+ | DefaultDeclOrigin -- Related to a `default' declaration
+
+ | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
+
+ -- Argument or result of a ccall
+ -- Dictionaries with this origin aren't actually mentioned in the
+ -- translated term, and so need not be bound. Nor should they
+ -- be abstracted over.
+
+ | CCallOrigin String -- CCall label
+ (Maybe RenamedHsExpr) -- Nothing if it's the result
+ -- Just arg, for an argument
+
+ | LitLitOrigin String -- the litlit
+
+ | UnknownOrigin -- Help! I give up...
+\end{code}
+
+\begin{code}
+-- During deriving and instance specialisation operations
+-- we can't get the instances of the class from inside the
+-- class, because the latter ain't ready yet. Instead we
+-- find a mapping from classes to envts inside the dict origin.
+
+get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
+get_inst_env clas (DerivingOrigin inst_mapper _ _)
+ = fst (inst_mapper clas)
+get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
+ = fst (inst_mapper clas)
+get_inst_env clas other_orig = getClassInstEnv clas
+
+
+pprOrigin :: PprStyle -> InstOrigin s -> Pretty
+
+pprOrigin sty (OccurrenceOf id)
+ = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
+ ppr sty id, ppChar '\'']
+pprOrigin sty (OccurrenceOfCon id)
+ = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
+ ppr sty id, ppChar '\'']
+pprOrigin sty (InstanceDeclOrigin)
+ = ppStr "in an instance declaration"
+pprOrigin sty (LiteralOrigin lit)
+ = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
+pprOrigin sty (ArithSeqOrigin seq)
+ = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
+pprOrigin sty (SignatureOrigin)
+ = ppStr "in a type signature"
+pprOrigin sty (DoOrigin)
+ = ppStr "in a do statement"
+pprOrigin sty (ClassDeclOrigin)
+ = ppStr "in a class declaration"
+pprOrigin sty (DerivingOrigin _ clas tycon)
+ = ppBesides [ppStr "in a `deriving' clause; class `",
+ ppr sty clas,
+ ppStr "'; offending type `",
+ ppr sty tycon,
+ ppStr "'"]
+pprOrigin sty (InstanceSpecOrigin _ clas ty)
+ = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
+ ppr sty clas, ppStr "\" type: ", ppr sty ty]
+pprOrigin sty (DefaultDeclOrigin)
+ = ppStr "in a `default' declaration"
+pprOrigin sty (ValSpecOrigin name)
+ = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
+ ppr sty name, ppStr "'"]
+pprOrigin sty (CCallOrigin clabel Nothing{-ccall result-})
+ = ppBesides [ppStr "in the result of the _ccall_ to `",
+ ppStr clabel, ppStr "'"]
+pprOrigin sty (CCallOrigin clabel (Just arg_expr))
+ = ppBesides [ppStr "in an argument in the _ccall_ to `",
+ ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
+pprOrigin sty (LitLitOrigin s)
+ = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
+pprOrigin sty UnknownOrigin
+ = ppStr "in... oops -- I don't know where the overloading came from!"
+\end{code}
+
+
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Spec where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import HsExpr(Expr)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst, InstOrigin)
-import LIE(LIE)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyVar(TyVar)
-import UniType(UniType)
-specId :: Id -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((Expr Id TypecheckedPat, LIE, UniType), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-specTy :: InstOrigin -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (([TyVar], [Inst], UniType), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-%************************************************************************
-%* *
-\section[Spec]{Specialisation of variables}
-%* *
-%************************************************************************
-
-One thing which happens {\em a lot} is the instantiation of a type scheme
-caused by the occurrence of a variable. It is so important that it
-is written below in a very ``open-code'' fashion. All the modular monadery
-is discarded, and we work directly in terms of the underlying representations.
-In particular, this function knows about
-
- - the TcM monad
- - the representation of UniTypes
-
-\begin{code}
-#include "HsVersions.h"
-
-module Spec ( specId, specTy ) where
-
-import AbsSyn
-import TcMonadFns ( copyTyVars, newDicts )
-import TcMonad
-
-import AbsUniType {- ( instantiateTauTy, instantiateThetaTy,
- cloneTyVarFromTemplate, splitType
- ) -} -- pragmas want to see it all!
-import Id ( getIdUniType, mkInstId, DictVar(..) )
-import Inst -- ( mkMethod, InstOrigin(..), Inst, InstTemplate, SpecInfo )
-import LIE
-import Subst ( getSubstTyVarUnique )
-import UniType -- known **GRIEVOUS** violation of UniType abstractness!!!
-import SplitUniq
-import Unique
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Spec-specId]{Instantiating an Id}
-%* *
-%************************************************************************
-
-@specId@ takes an @Id@ and implements the SPEC and REL rules
-returning
- - the id applied to suitable types and dictionaries
- - the LIE
- - its instantiated tau type
-
-For efficiency, it knows about the TcM implementation.
-
-\begin{code}
-specId :: Id -> NF_TcM (TypecheckedExpr, LIE, TauType)
-
-specId id sw_chkr dtys subst uniq errs src_loc
- = case (spec_sigma subst uniq src_loc id (getIdUniType id)) of
- (result, subst2) -> (result, subst2, errs)
-\end{code}
-
-\begin{code}
-spec_sigma :: Subst -- TyVar unique supply inside *here*
- -> SplitUniqSupply -- "normal" unique supply
- -> SrcLoc
- -> Id
- -> UniType
- -> ((TypecheckedExpr, LIE, TauType), Subst)
-
-spec_sigma subst uniq src_loc id (UniSyn _ _ ty)
- = spec_sigma subst uniq src_loc id ty
-
-spec_sigma subst uniq src_loc id ty@(UniForall _ _)
- = collect [] [] subst ty
- where
- collect tenv tyvar_tys subst (UniForall tyvar ty)
- = case (getSubstTyVarUnique subst) of
- (subst', u) ->
- collect ((tyvar, new_tyvar_ty) : tenv)
- (new_tyvar_ty : tyvar_tys)
- subst' ty
- where
- new_tyvar_ty = UniTyVar (cloneTyVarFromTemplate tyvar u)
-
- collect tenv tyvar_tys subst ty
- = spec_rho tenv (reverse tyvar_tys) subst uniq src_loc id ty
-
-spec_sigma subst uniq src_loc id tau_ty
- -- Not polymorphic => cannot be overloaded
- = ((Var id, nullLIE, tau_ty), subst)
-\end{code}
-
-\begin{code}
-spec_rho :: [(TyVarTemplate, UniType)] -> [UniType]
- -> Subst -> SplitUniqSupply -> SrcLoc
- -> Id -> UniType
- -> ((TypecheckedExpr, LIE, TauType), Subst)
-
-spec_rho tenv tys subst uniqs src_loc id (UniSyn _ _ ty)
- = spec_rho tenv tys subst uniqs src_loc id ty
-
-spec_rho tenv tys subst uniqs src_loc id (UniFun (UniDict _ _) ty)
- = ((Var inst_id, unitLIE method, instantiateTauTy tenv tau_ty),
- subst)
- where
- method = mkMethod u id tys (OccurrenceOf id src_loc)
- inst_id = mkInstId method
- u = getSUnique uniqs
- tau_ty = discard_dicts ty
-
- discard_dicts (UniFun (UniDict _ _) ty) = discard_dicts ty
- discard_dicts other_ty = other_ty
-
-spec_rho tenv tys subst uniqs src_loc id tau_ty
- = ((TyApp (Var id) tys, nullLIE, instantiateTauTy tenv tau_ty),
- subst)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Spec-specTy]{Instantiating a type}
-%* *
-%************************************************************************
-
-@specTy@ takes a polymorphic type, and instantiates it with fresh type
-variables. It strips off the context part, gets fresh dictionary
-variables for each predicate in the context. It returns
-
- - a list of the dictionary variables (remember they contain
- their types)
- - an instantiated tau-type
-
-The returned values are fixed points of the current substitution
-though the arguments may not be.
-
-\begin{code}
-specTy :: InstOrigin -> SigmaType -> NF_TcM ([TyVar], [Inst], TauType)
-
-specTy origin sigma_ty
- = let
- (old_tyvars, theta, tau_ty) = splitType sigma_ty
- in
- -- make new tyvars for each of the universally quantified type vars
- copyTyVars old_tyvars `thenNF_Tc` \ (inst_env, new_tyvars, _) ->
-
- -- instantiate the tau type
- let
- tau_ty' = instantiateTauTy inst_env tau_ty
- in
- -- instantiate the dictionary types
- newDicts origin (instantiateThetaTy inst_env theta) `thenNF_Tc` \ dicts ->
-
- -- return the list of tyvars, the list of dicts and the tau type
- returnNF_Tc ( new_tyvars, dicts, tau_ty' )
-\end{code}
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Subst where
-import Bag(Bag)
-import Class(Class)
-import Maybes(Labda)
-import PreludeGlaST(_MutableArray)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique)
-data Subst
-data SubstResult = SubstOK | OccursCheck TyVar UniType | AlreadyBound UniType
-data TyVar
-data UniType
-applySubstToThetaTy :: Subst -> [(Class, UniType)] -> (Subst, [(Class, UniType)])
-applySubstToTy :: Subst -> UniType -> (Subst, UniType)
-applySubstToTyVar :: Subst -> TyVar -> (Subst, UniType)
-combineSubstUndos :: Subst -> Subst
-extendSubst :: TyVar -> UniType -> Subst -> (Subst, SubstResult)
-getSubstTyVarUnique :: Subst -> (Subst, Unique)
-getSubstTyVarUniques :: Int -> Subst -> (Subst, [Unique])
-mkEmptySubst :: Int -> Subst
-pushSubstUndos :: Subst -> Subst
-undoSubstUndos :: Subst -> Subst
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Subst]{Substitutions}
-
-\begin{code}
-#include "HsVersions.h"
-
-module Subst (
- Subst, SubstResult(..), -- Subst is an abstract data type
-
- mkEmptySubst, extendSubst,
-
---not exported: applySubstToTauTy,
- applySubstToTy,
- applySubstToThetaTy, applySubstToTyVar,
-
- getSubstTyVarUniques, getSubstTyVarUnique,
-
- pushSubstUndos, combineSubstUndos, undoSubstUndos,
- -- pruneSubst,
-
- -- and to make the interface self-sufficient...
- TyVar, UniType
- ) where
-
-import AbsUniType -- lots of stuff, plus...
-import UniType -- UniType(..) -- *********** YOW!!! ********
-import Bag ( emptyBag, unionBags, snocBag,
- bagToList, filterBag, unitBag, Bag )
-import Maybes ( Maybe(..), maybeToBool )
-import Outputable
-import Unique
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Subst-magic-importst]{Funny imports to support magic implementation}
-%* *
-%************************************************************************
-
-Or lack thereof.
-
-If we are compiling with Glasgow Haskell we can use mutable
-arrays to implement the substitution ...
-
-\begin{code}
-#ifndef __GLASGOW_HASKELL__
-
-import LiftMonad
-
-#else {- __GLASGOW_HASKELL__ -}
-
-import PreludeGlaST
-
-type STWorld = _State _RealWorld
-
-newWorld (S# real_world) = S# real_world
-
-#endif {- __GLASGOW_HASKELL__ -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Subst-common]{@Subst@: common implementation-independent bits}
-%* *
-%************************************************************************
-
-\begin{code}
-data SubstResult
- = SubstOK
- | OccursCheck TyVar
- TauType
- | AlreadyBound TauType -- The variable is already bound
- -- to this type. The type is *not*
- -- necessarily a fixed pt of the
- -- substitution
-\end{code}
-
-Common signatures of major functions.
-
-\begin{code}
-mkEmptySubst :: Int -> Subst
-\end{code}
-
-%---------
-
-@extendSubst@: Add a single binding to the substitution. We have to:
-\begin{itemize}
-\item
-apply the existing bindings to the new one;
-\item
-check whether we are adding a trivial substitution of a type
-variable to itself (if so, do nothing);
-\item
-perform an occurs check on the right-hand side of the new binding;
-\end{itemize}
-We do not apply the new binding to all the existing ones. This is
-delayed until the substitution is applied.
-\begin{code}
-extendSubst :: TyVar -- Tyvar to bind
- -> TauType -- Type to bind it to; NB can be a synonym
- -> SubstM SubstResult
-\end{code}
-
-%---------
-
-Apply a substitution to a given type.
-
- {\em The type returned is guaranteed to be
- a fixed point of the substitution.}
-
-Hence, we have to traverse the type determining the type mapped to
-tyvars. The type mapped must be recusively traversed as the substition
-is not stored idempotently.
-
-@applySubstToTauTy@ does not expect to meet a dict or forall type.
-@applySubstToTy@ may encounter these, but complains if the forall
-binds a variable which is in the domain of the substitution.
-
-\begin{code}
-applySubstToTy :: Subst -> UniType -> (Subst, UniType)
-applySubstToTauTy :: Subst -> TauType -> (Subst, TauType)
-applySubstToThetaTy :: Subst -> ThetaType -> (Subst, ThetaType)
-applySubstToTyVar :: Subst -> TyVar -> (Subst, TauType)
-\end{code}
-
-These functions are only used by the type checker. We know that
-all the for-all'd type variables are fixed points of the substitution,
-so it's quite safe just to apply the substitution inside foralls.
-
-%---------
-
-Sorta obvious.
-\begin{code}
-getSubstTyVarUnique :: Subst -> (Subst, Unique)
-getSubstTyVarUniques :: Int -> Subst -> (Subst, [Unique])
-\end{code}
-
-%---------
-
-@pushSubstUndos@ starts a new subst undo scope, saving the old scopes.
-It also saves the current unique supply so that it can be restored if
-the typecheck fails.
-
-@combineSubstUndos@ is called after a successful typecheck. It
-combines the current undos with the previos ones in case we fail in an
-outer scope. If no previous undos exist the undos are thrown away as
-we must have succeeded at the top level. The unique supply of the
-successful scope is returned to the unique supply of the current
-scope.
-
-@undoSubstUndos@ is called when a typecheck failed. The any
-substitution modifications are undone and the undo information
-discarded. The saved unique supply of the enclosing scope is restored.
-\begin{code}
-pushSubstUndos, combineSubstUndos, undoSubstUndos :: Subst -> Subst
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Subst-Arrays]{@Subst@ with mutable @Arrays@ !!!}
-%* *
-%************************************************************************
-
-Depends on....
-\begin{code}
-#ifdef __GLASGOW_HASKELL__
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{@Subst@: specification and representation}
-%* *
-%************************************************************************
-
-{\em Specification:}
-* When new bindings are added to the substitution, an occurs check is performed.
-* The applySubst function guarantees to return a fixed point of the substitution.
-
-{\em Representation:}
-A substitution binds type variables to tau-types, that is @UniType@s without
-any @UniForall@ or @UniDict@ constructors.
-
-It is represented as an array, indexed on Int, with a world
-token, and a stack of type variables whos subst may be undone. The
-array is extended (by copying) if it overflows. The supply of
-Ints and the size of the array are linked so the substitution
-is also responsible for allocating the supply of uniques.
-
-The undo information is a stack of bags of the nested modifications to
-the substitution. If the typecheck fails the modifications to the
-substition are undone. If it succeeds the current undos are combined
-with the undos in the enclosing scope so that they would be undone if
-the enclsing scope typecheck fails.
-
-The unique supply is also stacked so that it can be restored if a
-typecheck fails.
-
-NOTE: The uniqueness of the world token, and hence the substitution,
-is critical as the 'worldSEQ' operation is unsafe if the token can be
-duplicated!!!
-
-\begin{code}
-type SubstArray = _MutableArray _RealWorld Int (Maybe TauType)
-
-type SubstArrayIndex = Int -- Allocated within this module, single-threadedly
-
-data Subst
- = MkSubst SubstArray -- Mapping for allocated tyvars
-
- [(SubstArrayIndex, Bag (SubstArrayIndex, Maybe TauType))]
- -- Stack to be undone if we fail, plus next free
- -- slot when reverting. All the undos are for
- -- slots earlier than the corresp "next free" index.
- --
- -- The "bag" is a lie: it's really a sequence, with
- -- the most recently performed write appearing first.
-
- STWorld -- State token
-
- SubstArrayIndex -- Next free slot
-\end{code}
-
-Here's a local monad for threading the substitution around:
-
-\begin{code}
-type SubstM a = Subst -> (Subst,a)
-
-returnSubstM x = \s -> (s,x)
-thenSubstM m k = \s -> case m s of { (s1, r) -> k r s1 }
-
-mapSubstM f [] = returnSubstM []
-mapSubstM f (x:xs) = f x `thenSubstM` \ r ->
- mapSubstM f xs `thenSubstM` \ rs ->
- returnSubstM (r:rs)
-
--- Breaks the ST abstraction. But we have to do so somewhere...
-doST :: STWorld -> ST _RealWorld a -> (a, STWorld)
-doST w st = st w
-\end{code}
-
-%********************************************************
-%* *
-\subsubsection{@Subst@: the array}
-%* *
-%********************************************************
-
-\begin{code}
-writeSubst :: SubstArrayIndex -> Maybe TauType -> SubstM ()
- -- writeSubst writes in such a way that we can undo it later
-
-writeSubst index new_val
- (MkSubst arr undo_stack@((checkpoint, undos):rest_undo_stack)
- world next_free)
- | index < checkpoint -- Record in undos
- = let
- (old, new_world) = doST world (
- readArray arr index `thenStrictlyST` \ old_val ->
- writeArray arr index new_val `seqStrictlyST`
- returnStrictlyST old_val
- )
- new_undos = unitBag (index,old) `unionBags` undos
- -- The order is significant! The right most thing
- -- gets undone last
- in
- (MkSubst arr ((checkpoint, new_undos) : rest_undo_stack) new_world next_free, ())
-
-writeSubst index new_val (MkSubst arr undo_stack world next_free)
- -- No need to record in undos: undo_stack is empty,
- -- or index is after checkpoint
- = let
- (_, new_world) = doST world (writeArray arr index new_val)
- in
- (MkSubst arr undo_stack new_world next_free, ())
-
-readSubst :: SubstArrayIndex -> SubstM (Maybe TauType)
-readSubst index (MkSubst arr undos world supplies)
- = let
- (result, new_world) = doST world (readArray arr index)
- in
- (MkSubst arr undos new_world supplies, result)
-
-tyVarToIndex :: TyVar -> SubstArrayIndex
-tyVarToIndex tyvar = unpkUnifiableTyVarUnique (getTheUnique tyvar)
-\end{code}
-
-%********************************************************
-%* *
-\subsubsection{@Subst@: building them}
-%* *
-%********************************************************
-
-The function @mkEmptySubst@ used to be a CAF containing a mutable
-array. The imperative world had a name for this kind of thing:
-``global variable'' and has observed that using these ``global variables''
-leads to something they call ``side effects''.
-
-These ``side effects'' never caused a problem for @hsc@ because empty
-substitutions are only used in one place (the typechecker) and only
-used once in every program run. In \tr{ghci} however, we might use the
-typechecker several times---in which case we'd like to have a
-different (fresh) substitution each time. The easy way (HACK) to
-achieve this is to deCAFinate so that a fresh substitution will be
-created each time the typechecker runs.
-
-\begin{code}
-aRRAY_START :: Int
-aRRAY_START = 0
-
-mkEmptySubst aRRAY_SIZE
- = let
- world = newWorld (S# realWorld#)
- (arr, new_world) = doST world (newArray (aRRAY_START,aRRAY_SIZE) Nothing)
- in
- MkSubst arr [] new_world aRRAY_START
-
-extendSubstArr :: Subst
- -> Subst
-extendSubstArr (MkSubst old_arr undos world next_free)
- = let
- -- these "sizes" are really end-limits (WDP 94/11)
- cur_size = case (boundsOfArray old_arr) of { (_, x) -> x }
- new_size = (cur_size * 2) + 1
-
- (new_arr, new_world) = doST world (
- newArray (aRRAY_START,new_size) Nothing `thenStrictlyST` \ new_arr ->
- let
- copyArr pos
- | pos > cur_size = returnStrictlyST ()
- | otherwise
- = readArray old_arr pos `thenStrictlyST` \ ele ->
- writeArray new_arr pos ele `seqStrictlyST`
- copyArr (pos + 1)
- in
- copyArr aRRAY_START `seqStrictlyST`
- returnStrictlyST new_arr
- )
- in
- MkSubst new_arr undos new_world next_free
-\end{code}
-
-\begin{code}
-extendSubst tyvar tau_ty
- = readSubst index `thenSubstM` \ maybe_ty ->
-
- case maybe_ty of
- Just exist_ty -> -- Bound already
- returnSubstM (AlreadyBound exist_ty)
-
- Nothing -> -- Not already bound
- apply_rep_to_ty tau_ty `thenSubstM` \ new_tau_ty ->
- case expandVisibleTySyn new_tau_ty of
- UniTyVar tv | tv `eqTyVar` tyvar ->
- -- Trivial new binding of a type variable to itself;
- -- return old substition
- returnSubstM SubstOK
-
- other | tyvar `is_elem` (extractTyVarsFromTy new_tau_ty) ->
- -- Occurs check finds error
- returnSubstM (OccursCheck tyvar new_tau_ty)
-
- | otherwise ->
- -- OK to bind
- writeSubst index (Just new_tau_ty) `thenSubstM` \ _ ->
- returnSubstM SubstOK
- where
- index = tyVarToIndex tyvar
- is_elem = isIn "extendSubst"
-\end{code}
-
-%********************************************************
-%* *
-\subsubsection{@Subst@: lookup}
-%* *
-%********************************************************
-
-All of them use the underlying function, @apply_rep_to_ty@, which
-ensures that an idempotent result is returned.
-
-\begin{code}
-applySubstToTy subst ty = apply_rep_to_ty ty subst
-applySubstToTauTy subst tau_ty = apply_rep_to_ty tau_ty subst
-applySubstToTyVar subst tyvar = apply_rep_to_ty (mkTyVarTy tyvar) subst
-applySubstToThetaTy subst theta_ty
- = let
- do_one (clas, ty) = apply_rep_to_ty ty `thenSubstM` \ new_ty ->
- returnSubstM (clas, new_ty)
- in
- mapSubstM do_one theta_ty subst
-\end{code}
-
-And now down to serious business...
-\begin{code}
-apply_rep_to_ty :: UniType -> SubstM UniType
-
-apply_rep_to_ty (UniTyVar tyvar)
- = readSubst index `thenSubstM` \ maybe_ty ->
- case maybe_ty of
-
- Nothing -> -- Not found, so return a trivial type
- returnSubstM (mkTyVarTy tyvar)
-
- Just ty -> -- Found, so recursively apply the subst the result to
- -- maintain idempotence!
- apply_rep_to_ty ty `thenSubstM` \ new_ty ->
-
- -- The mapping for this tyvar is then updated with the
- -- result to reduce the number of subsequent lookups
- writeSubst index (Just new_ty) `thenSubstM` \ _ ->
-
- returnSubstM new_ty
- where
- index = tyVarToIndex tyvar
-
-apply_rep_to_ty (UniFun t1 t2)
- = apply_rep_to_ty t1 `thenSubstM` \ new_t1 ->
- apply_rep_to_ty t2 `thenSubstM` \ new_t2 ->
- returnSubstM (UniFun new_t1 new_t2)
-
-apply_rep_to_ty (UniData con args)
- = mapSubstM apply_rep_to_ty args `thenSubstM` \ new_args ->
- returnSubstM (UniData con new_args)
-
-apply_rep_to_ty (UniSyn con args ty)
- = mapSubstM apply_rep_to_ty args `thenSubstM` \ new_args ->
- apply_rep_to_ty ty `thenSubstM` \ new_ty ->
- returnSubstM (UniSyn con new_args new_ty)
-
-apply_rep_to_ty (UniDict clas ty)
- = apply_rep_to_ty ty `thenSubstM` \ new_ty ->
- returnSubstM (UniDict clas new_ty)
-
-apply_rep_to_ty (UniForall v ty)
- = apply_rep_to_ty ty `thenSubstM` \ new_ty ->
- returnSubstM (UniForall v new_ty)
-
-apply_rep_to_ty ty@(UniTyVarTemplate v) = returnSubstM ty
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Allocating @TyVarUniques@}
-%* *
-%************************************************************************
-
-The array is extended if the allocated type variables would cause an
-out of bounds error.
-
-\begin{code}
-getSubstTyVarUnique subst@(MkSubst arr undo world next_free)
- | next_free <= size -- The common case; there's a spare slot
- = (MkSubst arr undo world new_next_free, uniq)
-
- | otherwise -- Need more room: Extend first, then re-try
- = getSubstTyVarUnique (extendSubstArr subst)
-
- where
- size = case (boundsOfArray arr) of { (_, x) -> x }
- uniq = mkUnifiableTyVarUnique next_free
- new_next_free = next_free + 1
-
-
-getSubstTyVarUniques n subst@(MkSubst arr undo world next_free)
- | new_next_free - 1 <= size -- The common case; there's a spare slot
- = (MkSubst arr undo world new_next_free, uniqs)
-
- | otherwise -- Need more room: extend, then re-try
- = getSubstTyVarUniques n (extendSubstArr subst)
-
- where
- size = case (boundsOfArray arr) of { (_, x) -> x }
- uniqs = [mkUnifiableTyVarUnique (next_free + i) | i <- [0..n-1]]
- new_next_free = next_free + n
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Undoing substitution on typechecking failure}
-%* *
-%************************************************************************
-
-\begin{code}
-pushSubstUndos (MkSubst arr undos world next_free)
- = MkSubst arr ((next_free,emptyBag):undos) world next_free
-
-combineSubstUndos (MkSubst arr [_] world next_free)
- = MkSubst arr [] world next_free -- top level undo ignored
-
-combineSubstUndos (MkSubst arr ((_,u1):(checkpoint,u2):undo_stack)
- world next_free)
- = MkSubst arr ((checkpoint, new_u1 `unionBags` u2):undo_stack) world next_free
- where
- -- Keep only undos which apply to indices before checkpoint
- new_u1 = filterBag (\ (index,val) -> index < checkpoint) u1
-
-undoSubstUndos (MkSubst arr ((checkpoint,undo_now):undo_stack) world next_free)
- = MkSubst arr undo_stack new_world checkpoint
- where
- (_, new_world) = doST world (perform_undo (bagToList undo_now) `seqStrictlyST`
- clear_block checkpoint
- )
-
- perform_undo [] = returnStrictlyST ()
- perform_undo ((index,val):undos) = writeArray arr index val `seqStrictlyST`
- perform_undo undos
-
- -- (clear_block n) clears the array from n up to next_free
- -- This is necessary because undos beyond supp2 aren't recorded in undos
- clear_block n | n >= next_free = returnStrictlyST ()
- | otherwise = writeArray arr n Nothing `seqStrictlyST`
- clear_block (n+1)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Pruning a substitution}
-%* *
-%************************************************************************
-
-ToDo: Implement with array !! Ignore? Restore unique supply?
-
-@pruneSubst@ prunes a substitution to a given level.
-
-This is tricky stuff. The idea is that if we
- (a) catch the current unique supply
- (b) do some work
- (c) back-substitute over the results of the work
- (d) prune the substitution back to the level caught in (a)
-then everything will be fine. Any *subsequent* unifications to
-these just-pruned ones will be added and not subsequently deleted.
-
-NB: this code relies on the idempotence property, otherwise discarding
-substitions might be dangerous.
-
-\begin{code}
-{-
-pruneSubst :: TyVarUnique -> Subst -> Subst
-
-pruneSubst keep_marker (MkSubst subst_rep)
- = -- BSCC("pruneSubst")
- MkSubst [(tyvar,ty) | (tyvar,ty) <- subst_rep,
- getTheUnique tyvar `ltUnique` keep_marker]
- -- ESCC
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Subst-Lists]{@Subst@ with poor list implementation}
-%* *
-%************************************************************************
-
-If don't have Glasgow Haskell we have to revert to list implementation
-of arrays ...
-
-\begin{code}
-#else {- ! __GLASGOW_HASKELL__ -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{@Subst@: specification and representation}
-%* *
-%************************************************************************
-
-{\em Specification:}
-* When new bindings are added to the substitution, an occurs check is performed.
-* The applySubst function guarantees to return a fixed point of the substitution.
-
-{\em Representation:}
-A substitution binds type variables to tau-types, that is @UniType@s without
-any @UniForall@ or @UniDict@ constructors.
-
-It is represented as an association list, indexed on Uniques
-with a stack of type variable unique markers indicating undo
-checkpoints. The supply of TyVarUniques is also part of the
-aubstitution.
-
-The undo information is a stack of tyvar markers. If the typecheck
-fails all extensions to the association list subsequent to (and
-including) the marker are undone. If it succeeds the current marker is
-discarded.
-
-The unique supply is also stacked so that it can be restored if a
-typecheck fails.
-
-\begin{code}
-type SubstRep = [(Unique, TauType)]
-
-data Subst
- = MkSubst SubstRep -- mapping for allocated tyvars
- [Maybe Unique] -- stack of markers to strip off if we fail
- [UniqueSupply] -- stack of tyvar unique supplies
-
-mkEmptySubst size = MkSubst [] [] []
-\end{code}
-
-\begin{code}
-lookup_rep :: SubstRep -> TyVar -> Maybe TauType
-lookup_rep alist tyvar
- = let
- key = getTheUnique tyvar
-
- lookup [] = Nothing
- lookup ((u,ty):rest)
- = case (cmpUnique key u) of { EQ_ -> Just ty; _ -> lookup rest }
- in
- lookup alist
-\end{code}
-
-%********************************************************
-%* *
-\subsubsection{@Subst@: building them}
-%* *
-%********************************************************
-
-\begin{code}
---OLD? initSubst init = MkSubst [] [] [mkUniqueSupply init]
-\end{code}
-
-\begin{code}
-extendSubst subst@(MkSubst srep undo supp) tyvar tau_ty
- = -- BSCC("extendSubst")
- apply_rep_to_ty srep tau_ty `thenLft` \ new_tau_ty ->
-
- case expandVisibleTySyn new_tau_ty of
-
- UniTyVar tv | tv `eqTyVar` tyvar ->
- -- Trivial new binding; return old substition
- (SubstOK, subst)
-
- _ -> let
- is_elem = isIn "extendSubst2"
- in
- if (tyvar `is_elem` (extractTyVarsFromTy new_tau_ty)) then
- (OccursCheck tyvar new_tau_ty, subst)
- else
- case lookup_rep srep tyvar of
- Just exist_ty ->
- (AlreadyBound exist_ty, subst)
- Nothing ->
- let
- new_srep = (getTheUnique tyvar, new_tau_ty) : srep
- new_undo = case undo of
- [] -> []
- -- top level undo ignored
-
- (Nothing : undos) -> (Just (getTheUnique tyvar)) : undos
- (Just _ : _ ) -> undo
- -- only first undo recorded
- in
- (SubstOK, MkSubst new_srep new_undo supp)
- -- ESCC
-\end{code}
-
-%********************************************************
-%* *
-\subsubsection{@Subst@: lookup}
-%* *
-%********************************************************
-
-All of them use the underlying function, @apply_rep_to_ty@, which
-ensures that an idempotent result is returned.
-
-\begin{code}
-applySubstToTy subst@(MkSubst srep undo supp) ty
- = -- BSCC("applySubstToTy")
- apply_rep_to_ty srep ty `thenLft` \ new_ty ->
- (subst, new_ty)
- -- ESCC
-
-applySubstToTauTy subst@(MkSubst srep undo supp) tauty
- = -- BSCC("applySubstToTauTy")
- apply_rep_to_ty srep tauty `thenLft`\ new_tauty ->
- (subst, new_tauty)
- -- ESCC
-
-applySubstToThetaTy subst@(MkSubst srep undo supp) theta
- = -- BSCC("applySubstToThetaTy")
- let
- do_one (clas, ty) = apply_rep_to_ty srep ty `thenLft` \ new_ty ->
- returnLft (clas, new_ty)
- in
- mapLft do_one theta `thenLft` \ new_theta ->
- (subst, new_theta)
- -- ESCC
-
-applySubstToTyVar subst@(MkSubst srep undo supp) tyvar
- = -- BSCC("applySubstToTyVar")
- apply_rep_to_ty srep (mkTyVarTy tyvar) `thenLft` \ new_tauty ->
- (subst, new_tauty)
- -- ESCC
-\end{code}
-
-And now down to serious business...
-\begin{code}
-apply_rep_to_ty :: SubstRep -> UniType -> LiftM UniType
-
-apply_rep_to_ty srep (UniTyVar tyvar)
- = case lookup_rep srep tyvar of
- Nothing -> -- Not found, so return a trivial type
- returnLft (mkTyVarTy tyvar)
-
- Just ty -> -- Found, so recursively apply the subst the result to
- -- maintain idempotence!
- apply_rep_to_ty srep ty
-
-apply_rep_to_ty srep (UniFun t1 t2)
- = apply_rep_to_ty srep t1 `thenLft` \ new_t1 ->
- apply_rep_to_ty srep t2 `thenLft` \ new_t2 ->
- returnLft (UniFun new_t1 new_t2)
-
-apply_rep_to_ty srep (UniData con args)
- = mapLft (apply_rep_to_ty srep) args `thenLft` \ new_args ->
- returnLft (UniData con new_args)
-
-apply_rep_to_ty srep (UniSyn con args ty)
- = mapLft (apply_rep_to_ty srep) args `thenLft` \ new_args ->
- apply_rep_to_ty srep ty `thenLft` \ new_ty ->
- returnLft (UniSyn con new_args new_ty)
-
-apply_rep_to_ty srep (UniDict clas ty)
- = apply_rep_to_ty srep ty `thenLft` \ new_ty ->
- returnLft (UniDict clas new_ty)
-
-apply_rep_to_ty srep (UniForall v ty)
- = apply_rep_to_ty srep ty `thenLft` \ new_ty ->
- returnLft (UniForall v new_ty)
-
-apply_rep_to_ty srep ty@(UniTyVarTemplate v) = returnLft ty
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Allocating TyVarUniques}
-%* *
-%************************************************************************
-
-The array is extended if the allocated type variables would cause an
-out of bounds error.
-
-\begin{code}
-getSubstTyVarUnique subst@(MkSubst srep undo (supp:supps))
- = -- BSCC("allocTyVarUniques")
- case getUnique supp of
- (new_supp, uniq) -> (MkSubst srep undo (new_supp:supps), uniq)
- -- ESCC
-
-getSubstTyVarUniques n subst@(MkSubst srep undo (supp:supps))
- = -- BSCC("allocTyVarUniques")
- case getUniques n supp of
- (new_supp, uniqs) -> (MkSubst srep undo (new_supp:supps), uniqs)
- -- ESCC
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Subst-undo]{Undoing substitution on typechecking failure}
-%* *
-%************************************************************************
-
-\begin{code}
-pushSubstUndos subst@(MkSubst srep undos (supp:supps))
- = -- BSCC("pushSubstUndos")
- MkSubst srep (Nothing:undos) (supp:supp:supps)
- -- ESCC
-
-combineSubstUndos subst@(MkSubst srep (u:us) (supp1:supp2:supps))
- = -- BSCC("combineSubstUndos")
- MkSubst srep us (supp1:supps)
- -- ESCC
-
-undoSubstUndos subst@(MkSubst srep (u:us) (supp1:supp2:supps))
- = -- BSCC("undoSubstUndos")
- let
- strip_to [] key = []
- strip_to ((u,ty):srep) key
- = case (cmpUnique u key) of { EQ_ -> srep; _ -> strip_to srep key }
-
- perform_undo Nothing srep = srep
- perform_undo (Just uniq) srep = strip_to srep uniq
- in
- MkSubst (perform_undo u srep) us (supp2:supps)
-
- -- Note: the saved unique supply is restored from the enclosing scope
-
- -- ESCC
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Pruning a substitution}
-%* *
-%************************************************************************
-
-ToDo: Implement with list !! Ignore? Restore unique supply?
-
-@pruneSubst@ prunes a substitution to a given level.
-
-This is tricky stuff. The idea is that if we
- (a) catch the current unique supply
- (b) do some work
- (c) back-substitute over the results of the work
- (d) prune the substitution back to the level caught in (a)
-then everything will be fine. Any *subsequent* unifications to
-these just-pruned ones will be added and not subsequently deleted.
-
-NB: this code relies on the idempotence property, otherwise discarding
-substitions might be dangerous.
-
-\begin{code}
-{-
-pruneSubst :: TyVarUnique -> Subst -> Subst
-
-pruneSubst keep_marker (MkSubst subst_rep)
- = -- BSCC("pruneSubst")
- MkSubst [(tyvar,ty) | (tyvar,ty) <- subst_rep,
- getTheUnique tyvar `ltUnique` keep_marker]
- -- ESCC
--}
-\end{code}
-
-\begin{code}
-#endif {- ! __GLASGOW_HASKELL__ -}
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcBinds where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import GenSpecEtc(SignatureInfo)
-import HsBinds(Binds, MonoBinds, Sig)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-doSpecPragma :: E -> (Name -> Id) -> SignatureInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (MonoBinds Id TypecheckedPat, LIE)
-tcLocalBindsAndThen :: E -> (Binds Id TypecheckedPat -> a -> a) -> Binds Name (InPat Name) -> (E -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)
-tcSigs :: E -> [(Name, Id)] -> [Sig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [SignatureInfo]
-tcTopBindsAndThen :: E -> (Binds Id TypecheckedPat -> a -> a) -> Binds Name (InPat Name) -> (E -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcBinds]{TcBinds}
\begin{code}
#include "HsVersions.h"
-module TcBinds (
- tcTopBindsAndThen, tcLocalBindsAndThen,
- tcSigs, doSpecPragma
- ) where
-
---IMPORT_Trace -- ToDo:rm (debugging)
-
-import TcMonad -- typechecking monad machinery
-import TcMonadFns ( newLocalsWithOpenTyVarTys,
- newLocalsWithPolyTyVarTys,
- newSpecPragmaId, newSpecId,
- applyTcSubstAndCollectTyVars
- )
-import AbsSyn -- the stuff being typechecked
-
-import AbsUniType ( isTyVarTy, isGroundTy, isUnboxedDataType,
- isGroundOrTyVarTy, extractTyVarsFromTy,
- UniType
- )
-import BackSubst ( applyTcSubstToBinds )
-import E
-import Errors ( topLevelUnboxedDeclErr, specGroundnessErr,
- specCtxtGroundnessErr, Error(..), UnifyErrContext(..)
- )
-import GenSpecEtc ( checkSigTyVars, genBinds, SignatureInfo(..) )
-import Id ( getIdUniType, mkInstId )
-import IdInfo ( SpecInfo(..) )
-import Inst
-import LIE ( nullLIE, mkLIE, plusLIE, LIE )
-import Maybes ( assocMaybe, catMaybes, Maybe(..) )
-import Spec ( specTy )
-import TVE ( nullTVE, TVE(..), UniqFM )
-import TcMonoBnds ( tcMonoBinds )
-import TcPolyType ( tcPolyType )
+module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where
+
+import Ubiq
+
+import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..),
+ HsExpr, Match, PolyType, InPat, OutPat,
+ GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
+ collectBinders )
+import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..),
+ RenamedMonoBinds(..) )
+import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
+ TcIdOcc(..), TcIdBndr(..) )
+
+import TcMonad
+import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
+import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
+import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
+import TcLoop ( tcGRHSsAndBinds )
+import TcMatches ( tcMatchesFun )
+import TcMonoType ( tcPolyType )
+import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
+import TcType ( newTcTyVar, tcInstType )
import Unify ( unifyTauTy )
-import UniqFM ( emptyUFM ) -- profiling, pragmas only
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Type-checking top-level bindings}
-%* *
-%************************************************************************
-
-@tcBindsAndThen@ takes a boolean which indicates whether the binding
-group is at top level or not. The difference from inner bindings is
-that
-\begin{enumerate}
-\item
-we zero the substitution before each group
-\item
-we back-substitute after each group.
-\end{enumerate}
-We still return an LIE, but it is sure to contain nothing but constant
-dictionaries, which we resolve at the module level.
-
-@tcTopBinds@ returns an LVE, not, as you might expect, a GVE. Why?
-Because the monomorphism restriction means that is might return some
-monomorphic things, with free type variables. Hence it must be an LVE.
-The LIE returned by @tcTopBinds@ may constrain some type variables,
-but they are guaranteed to be a subset of those free in the
-corresponding returned LVE.
+import Kind ( mkBoxedTypeKind, mkTypeKind )
+import Id ( GenId, idType, mkUserId )
+import IdInfo ( noIdInfo )
+import Name ( Name ) -- instances
+import Maybes ( assocMaybe, catMaybes, Maybe(..) )
+import Outputable ( pprNonOp )
+import PragmaInfo ( PragmaInfo(..) )
+import Pretty
+import Type ( mkTyVarTy, isTyVarTy, mkSigmaTy, splitSigmaTy,
+ splitRhoTy, mkForAllTy, splitForAllTy )
+import Util ( panic )
+\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-@tcBindsAndThen@ typechecks a @Binds@. The "and then" part is because
+@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
it needs to know something about the {\em usage} of the things bound,
so that it can create specialisations of them. So @tcBindsAndThen@
takes a function which, given an extended environment, E, typechecks
checked the type of its LHS is unified with that of its RHS; and
type-checking the LHS of course requires that the binder is in scope.
+At the top-level the LIE is sure to contain nothing but constant
+dictionaries, which we resolve at the module level.
+
\begin{code}
-tcBindsAndThen
- :: Bool
- -> E
- -> (TypecheckedBinds -> thing -> thing) -- Combinator
- -> RenamedBinds
- -> (E -> TcM (thing, LIE, thing_ty))
- -> TcM (thing, LIE, thing_ty)
-
-tcBindsAndThen top_level e combiner EmptyBinds do_next
- = do_next e `thenTc` \ (thing, lie, thing_ty) ->
+tcBindsAndThen
+ :: (TcHsBinds s -> thing -> thing) -- Combinator
+ -> RenamedHsBinds
+ -> TcM s (thing, LIE s, thing_ty)
+ -> TcM s (thing, LIE s, thing_ty)
+
+tcBindsAndThen combiner EmptyBinds do_next
+ = do_next `thenTc` \ (thing, lie, thing_ty) ->
returnTc (combiner EmptyBinds thing, lie, thing_ty)
-tcBindsAndThen top_level e combiner (SingleBind bind) do_next
- = tcBindAndThen top_level e combiner bind [] do_next
+tcBindsAndThen combiner (SingleBind bind) do_next
+ = tcBindAndThen combiner bind [] do_next
-tcBindsAndThen top_level e combiner (BindWith bind sigs) do_next
- = tcBindAndThen top_level e combiner bind sigs do_next
-
-tcBindsAndThen top_level e combiner (ThenBinds binds1 binds2) do_next
- = tcBindsAndThen top_level e combiner binds1 new_after
- where
- -- new_after :: E -> TcM (thing, LIE, thing_ty)
- -- Can't write this signature, cos it's monomorphic in thing and
- -- thing_ty.
- new_after e = tcBindsAndThen top_level e combiner binds2 do_next
-\end{code}
+tcBindsAndThen combiner (BindWith bind sigs) do_next
+ = tcBindAndThen combiner bind sigs do_next
-Simple wrappers for export:
-\begin{code}
-tcTopBindsAndThen
- :: E
- -> (TypecheckedBinds -> thing -> thing) -- Combinator
- -> RenamedBinds
- -> (E -> TcM (thing, LIE, anything))
- -> TcM (thing, LIE, anything)
-
-tcTopBindsAndThen e combiner binds do_next
- = tcBindsAndThen True e combiner binds do_next
-
-tcLocalBindsAndThen
- :: E
- -> (TypecheckedBinds -> thing -> thing) -- Combinator
- -> RenamedBinds
- -> (E -> TcM (thing, LIE, thing_ty))
- -> TcM (thing, LIE, thing_ty)
-
-tcLocalBindsAndThen e combiner binds do_next
- = tcBindsAndThen False e combiner binds do_next
+tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next
+ = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next)
\end{code}
An aside. The original version of @tcBindsAndThen@ which lacks a
examples of this, which is why I thought it worth preserving! [SLPJ]
\begin{pseudocode}
-tcBindsAndThen
- :: Bool -> E -> RenamedBinds
- -> (E -> TcM (thing, LIE, thing_ty))
- -> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
+tcBindsAndThen
+ :: RenamedHsBinds
+ -> TcM s (thing, LIE s, thing_ty))
+ -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
-tcBindsAndThen top_level e EmptyBinds do_next
- = do_next e `thenTc` \ (thing, lie, thing_ty) ->
+tcBindsAndThen EmptyBinds do_next
+ = do_next `thenTc` \ (thing, lie, thing_ty) ->
returnTc ((EmptyBinds, thing), lie, thing_ty)
-tcBindsAndThen top_level e (SingleBind bind) do_next
- = tcBindAndThen top_level e bind [] do_next
+tcBindsAndThen (SingleBind bind) do_next
+ = tcBindAndThen bind [] do_next
-tcBindsAndThen top_level e (BindWith bind sigs) do_next
- = tcBindAndThen top_level e bind sigs do_next
+tcBindsAndThen (BindWith bind sigs) do_next
+ = tcBindAndThen bind sigs do_next
-tcBindsAndThen top_level e (ThenBinds binds1 binds2) do_next
- = tcBindsAndThen top_level e binds1 new_after
+tcBindsAndThen (ThenBinds binds1 binds2) do_next
+ = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
`thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
-
- where
- -- new_after :: E -> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
- -- Can't write this signature, cos it's monomorphic in thing and thing_ty
- new_after e = tcBindsAndThen top_level e binds2 do_next
\end{pseudocode}
%************************************************************************
\begin{code}
tcBindAndThen
- :: Bool -- At top level
- -> E
- -> (TypecheckedBinds -> thing -> thing) -- Combinator
+ :: (TcHsBinds s -> thing -> thing) -- Combinator
-> RenamedBind -- The Bind to typecheck
-> [RenamedSig] -- ...and its signatures
- -> (E -> TcM (thing, LIE, thing_ty)) -- Thing to type check in
+ -> TcM s (thing, LIE s, thing_ty) -- Thing to type check in
-- augmented envt
- -> TcM (thing, LIE, thing_ty) -- Results, incl the
+ -> TcM s (thing, LIE s, thing_ty) -- Results, incl the
-tcBindAndThen top_level e combiner bind sigs do_next
- = -- Deal with the bind
- tcBind top_level e bind sigs `thenTc` \ (poly_binds, poly_lie, poly_lve) ->
+tcBindAndThen combiner bind sigs do_next
+ = fixTc (\ ~(prag_info_fn, _) ->
+ -- This is the usual prag_info fix; the PragmaInfo field of an Id
+ -- is not inspected till ages later in the compiler, so there
+ -- should be no black-hole problems here.
+
+ tcBindAndSigs binder_names bind
+ sigs prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
+
+ -- Extend the environment to bind the new polymorphic Ids
+ tcExtendLocalValEnv binder_names poly_ids $
+
+ -- Build bindings and IdInfos corresponding to user pragmas
+ tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
-- Now do whatever happens next, in the augmented envt
- do_next (growE_LVE e poly_lve) `thenTc` \ (thing, thing_lie, thing_ty) ->
+ do_next `thenTc` \ (thing, thing_lie, thing_ty) ->
+
+ -- Create specialisations of functions bound here
+ bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie)
+ poly_ids `thenTc` \ (lie2, inst_mbinds) ->
+
+ -- All done
let
- bound_ids = map snd poly_lve
+ final_lie = lie2 `plusLIE` poly_lie
+ final_binds = poly_binds `ThenBinds`
+ SingleBind (NonRecBind inst_mbinds) `ThenBinds`
+ prag_binds
in
- -- Create specialisations
- specialiseBinds bound_ids thing_lie poly_binds poly_lie
- `thenNF_Tc` \ (final_binds, final_lie) ->
- -- All done
- returnTc (combiner final_binds thing, final_lie, thing_ty)
+ returnTc (prag_info_fn, (combiner final_binds thing, final_lie, thing_ty))
+ ) `thenTc` \ (_, result) ->
+ returnTc result
+ where
+ binder_names = collectBinders bind
+
+
+tcBindAndSigs binder_names bind sigs prag_info_fn
+ = recoverTc (
+ -- If typechecking the binds fails, then return with each
+ -- binder given type (forall a.a), to minimise subsequent
+ -- error messages
+ newTcTyVar Nothing mkBoxedTypeKind `thenNF_Tc` \ alpha_tv ->
+ let
+ forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
+ poly_ids = [ mkUserId name forall_a_a (prag_info_fn name)
+ | name <- binder_names]
+ in
+ returnTc (EmptyBinds, emptyLIE, poly_ids)
+ ) $
+
+ -- Create a new identifier for each binder, with each being given
+ -- a type-variable type.
+ newMonoIds binder_names kind (\ mono_ids ->
+ tcTySigs sigs `thenTc` \ sig_info ->
+ tc_bind bind `thenTc` \ (bind', lie) ->
+ returnTc (mono_ids, bind', lie, sig_info)
+ )
+ `thenTc` \ (mono_ids, bind', lie, sig_info) ->
+
+ -- Notice that genBinds gets the old (non-extended) environment
+ 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
\end{code}
\begin{code}
-tcBind :: Bool -> E
- -> RenamedBind -> [RenamedSig]
- -> TcM (TypecheckedBinds, LIE, LVE) -- LIE is a fixed point of substitution
+tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s)
-tcBind False e bind sigs -- Not top level
- = tcBind_help False e bind sigs
+tc_bind (NonRecBind mono_binds)
+ = tcMonoBinds mono_binds `thenTc` \ (mono_binds2, lie) ->
+ returnTc (NonRecBind mono_binds2, lie)
-tcBind True e bind sigs -- Top level!
- = pruneSubstTc (tvOfE e) (
+tc_bind (RecBind mono_binds)
+ = tcMonoBinds mono_binds `thenTc` \ (mono_binds2, lie) ->
+ returnTc (RecBind mono_binds2, lie)
+\end{code}
- -- DO THE WORK
- tcBind_help True e bind sigs `thenTc` \ (new_binds, lie, lve) ->
+\begin{code}
+tcMonoBinds :: RenamedMonoBinds -> TcM s (TcMonoBinds s, LIE s)
-{- Top-level unboxed values are now allowed
- They will be lifted by the Desugarer (see CoreLift.lhs)
+tcMonoBinds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
- -- CHECK FOR PRIMITIVE TOP-LEVEL BINDS
- listTc [ checkTc (isUnboxedDataType (getIdUniType id))
- (topLevelUnboxedDeclErr id (getSrcLoc id))
- | (_,id) <- lve ] `thenTc_`
--}
+tcMonoBinds (AndMonoBinds mb1 mb2)
+ = tcMonoBinds mb1 `thenTc` \ (mb1a, lie1) ->
+ tcMonoBinds mb2 `thenTc` \ (mb2a, lie2) ->
+ returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
- -- Back-substitute over the binds, since we are about to discard
- -- a good chunk of the substitution.
- applyTcSubstToBinds new_binds `thenNF_Tc` \ final_binds ->
+tcMonoBinds bind@(PatMonoBind pat grhss_and_binds locn)
+ = tcAddSrcLoc locn $
- -- The lie is already a fixed point of the substitution; it just turns out
- -- that almost always this happens automatically, and so we made it part of
- -- the specification of genBinds.
- returnTc (final_binds, lie, lve)
- )
+ -- LEFT HAND SIDE
+ tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
+
+ -- BINDINGS AND GRHSS
+ tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
+
+ -- Unify the two sides
+ tcAddErrCtxt (patMonoBindsCtxt bind) $
+ unifyTauTy pat_ty grhss_ty `thenTc_`
+
+ -- RETURN
+ returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
+ plusLIE lie_pat lie)
+
+tcMonoBinds (FunMonoBind name matches locn)
+ = tcAddSrcLoc locn $
+ tcLookupLocalValueOK "tcMonoBinds" name `thenNF_Tc` \ id ->
+ tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) ->
+ returnTc (FunMonoBind (TcId id) matches' locn, lie)
\end{code}
+%************************************************************************
+%* *
+\subsection{Signatures}
+%* *
+%************************************************************************
+
+@tcSigs@ checks the signatures for validity, and returns a list of
+{\em freshly-instantiated} signatures. That is, the types are already
+split up, and have fresh type variables installed. All non-type-signature
+"RenamedSigs" are ignored.
+
\begin{code}
-tcBind_help top_level e bind sigs
- = -- Create an LVE binding each identifier to an appropriate type variable
- new_locals binders `thenNF_Tc` \ bound_ids ->
- let lve = binders `zip` bound_ids in
-
- -- Now deal with type signatures, if any
- tcSigs e lve sigs `thenTc` \ sig_info ->
-
- -- Check the bindings: this is the point at which we can use
- -- error recovery. If checking the bind fails we just
- -- return the empty bindings. The variables will still be in
- -- scope, but bound to completely free type variables, which
- -- is just what we want to minimise subsequent error messages.
- recoverTc (NonRecBind EmptyMonoBinds, nullLIE)
- (tc_bind (growE_LVE e lve) bind) `thenNF_Tc` \ (bind', lie) ->
-
- -- Notice that genBinds gets the old (non-extended) environment
- genBinds top_level e bind' lie lve sig_info `thenTc` \ (binds', lie, lve) ->
-
- -- Add bindings corresponding to SPECIALIZE pragmas in the code
- mapAndUnzipTc (doSpecPragma e (assoc "doSpecPragma" lve))
- (get_spec_pragmas sig_info)
- `thenTc` \ (spec_binds_s, spec_lie_s) ->
-
- returnTc (binds' `ThenBinds` (SingleBind (NonRecBind (
- foldr AndMonoBinds EmptyMonoBinds spec_binds_s))),
- lie `plusLIE` (foldr plusLIE nullLIE spec_lie_s),
- lve)
- where
- binders = collectBinders bind
+tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s]
+
+tcTySigs (Sig v ty _ src_loc : other_sigs)
+ = tcAddSrcLoc src_loc (
+ tcPolyType ty `thenTc` \ sigma_ty ->
+ tcInstType [] sigma_ty `thenNF_Tc` \ tc_sigma_ty ->
+ let
+ (tyvars, theta, tau_ty) = splitSigmaTy tc_sigma_ty
+ in
+ tcLookupLocalValueOK "tcSig1" v `thenNF_Tc` \ val ->
+ unifyTauTy (idType val) tau_ty `thenTc_`
+ returnTc (TySigInfo val tyvars theta tau_ty src_loc)
+ ) `thenTc` \ sig_info1 ->
+
+ tcTySigs other_sigs `thenTc` \ sig_infos ->
+ returnTc (sig_info1 : sig_infos)
+
+tcTySigs (other : sigs) = tcTySigs sigs
+tcTySigs [] = returnTc []
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{SPECIALIZE pragmas}
+%* *
+%************************************************************************
+
+
+@tcPragmaSigs@ munches up the "signatures" that arise through *user*
+pragmas. It is convenient for them to appear in the @[RenamedSig]@
+part of a binding because then the same machinery can be used for
+moving them into place as is done for type signatures.
+
+\begin{code}
+tcPragmaSigs :: [RenamedSig] -- The pragma signatures
+ -> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo
+ TcHsBinds s,
+ LIE s)
+
+tcPragmaSigs sigs = returnTc ( \name -> NoPragmaInfo, EmptyBinds, emptyLIE )
- new_locals binders
- = case bind of
- NonRecBind _ -> -- Recursive, so no unboxed types
- newLocalsWithOpenTyVarTys binders
+{-
+tcPragmaSigs sigs
+ = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (names_w_id_infos, binds, lies) ->
+ let
+ name_to_info name = foldr ($) noIdInfo
+ [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
+ in
+ returnTc (name_to_info,
+ foldr ThenBinds EmptyBinds binds,
+ foldr plusLIE emptyLIE lies)
+\end{code}
- RecBind _ -> -- Non-recursive, so we permit unboxed types
- newLocalsWithPolyTyVarTys binders
+Here are the easy cases for tcPragmaSigs
- get_spec_pragmas sig_info
- = catMaybes (map get_pragma_maybe sig_info)
- where
- get_pragma_maybe s@(ValSpecInfo _ _ _ _) = Just s
- get_pragma_maybe _ = Nothing
+\begin{code}
+tcPragmaSig (DeforestSig name loc)
+ = returnTc ((name, addInfo DoDeforest),EmptyBinds,emptyLIE)
+tcPragmaSig (InlineSig name loc)
+ = returnTc ((name, addInfo_UF (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
+tcPragmaSig (MagicUnfoldingSig name string loc)
+ = returnTc ((name, addInfo_UF (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
\end{code}
+The interesting case is for SPECIALISE pragmas. There are two forms.
+Here's the first form:
\begin{verbatim}
f :: Ord a => [a] -> b -> b
{-# SPECIALIZE f :: [Int] -> b -> b #-}
\end{verbatim}
-We generate:
+
+For this we generate:
\begin{verbatim}
- f@Int = /\ b -> let d1 = ...
- in f Int b d1
+ f* = /\ b -> let d1 = ...
+ in f Int b d1
+\end{verbatim}
+where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
+retain a right-hand-side that the simplifier will otherwise discard as
+dead code... the simplifier has a flag that tells it not to discard
+SpecPragmaId bindings.
- h :: Ord a => [a] -> b -> b
- {-# SPECIALIZE h :: [Int] -> b -> b #-}
+In this case the f* retains a call-instance of the overloaded
+function, f, (including appropriate dictionaries) so that the
+specialiser will subsequently discover that there's a call of @f@ at
+Int, and will create a specialisation for @f@. After that, the
+binding for @f*@ can be discarded.
+
+The second form is this:
+\begin{verbatim}
+ f :: Ord a => [a] -> b -> b
+ {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
+\end{verbatim}
- spec_h = /\b -> h [Int] b dListOfInt
- ^^^^^^^^^^^^^^^^^^^^ This bit created by specId
+Here @g@ is specified as a function that implements the specialised
+version of @f@. Suppose that g has type (a->b->b); that is, g's type
+is more general than that required. For this we generate
+\begin{verbatim}
+ f@Int = /\b -> g Int b
+ f* = f@Int
\end{verbatim}
+Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits
+f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves
+to prevent @f@@Int@ from being discarded prematurely. After specialisation,
+if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
+discard the f* binding.
+
+Actually, there is really only point in giving a SPECIALISE pragma on exported things,
+and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
+a bit of overkill.
+
\begin{code}
-doSpecPragma :: E
- -> (Name -> Id)
- -> SignatureInfo
- -> TcM (TypecheckedMonoBinds, LIE)
-
-doSpecPragma e name_to_id (ValSpecInfo name spec_ty using src_loc)
- = let
- main_id = name_to_id name -- Get the parent Id
-
- main_id_ty = getIdUniType main_id
- main_id_free_tyvars = extractTyVarsFromTy main_id_ty
- origin = ValSpecOrigin name src_loc
- err_ctxt = ValSpecSigCtxt name spec_ty src_loc
+tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
+
+ -- Get and instantiate its alleged specialised type
+ tcPolyType poly_ty `thenTc` \ sig_sigma ->
+ tcInstType [] (idType sig_sigma) `thenNF_Tc` \ sig_ty ->
+ let
+ (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
+ origin = ValSpecOrigin name
in
- addSrcLocTc src_loc (
- specTy origin spec_ty `thenNF_Tc` \ (spec_tyvars, spec_dicts, spec_tau) ->
-- Check that the SPECIALIZE pragma had an empty context
- checkTc (not (null spec_dicts))
+ checkTc (null sig_theta)
(panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
- -- Make an instance of this id
- specTy origin main_id_ty `thenNF_Tc` \ (main_tyvars, main_dicts, main_tau) ->
+ -- Get and instantiate the type of the id mentioned
+ tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
+ tcInstType [] (idType main_id) `thenNF_Tc` \ main_ty ->
+ let
+ (main_tyvars, main_rho) = splitForAllTy main_ty
+ (main_theta,main_tau) = splitRhoTy main_rho
+ main_arg_tys = map mkTyVarTy main_tyvars
+ in
-- Check that the specialised type is indeed an instance of
- -- the inferred type.
- -- The unification should leave all type vars which are
- -- currently free in the environment still free, and likewise
- -- the signature type vars.
- -- The only way type vars free in the envt could possibly be affected
- -- is if main_id_ty has free type variables. So we just extract them,
- -- and check that they are not constrained in any way by the unification.
- applyTcSubstAndCollectTyVars main_id_free_tyvars `thenNF_Tc` \ free_tyvars' ->
- unifyTauTy spec_tau main_tau err_ctxt `thenTc_`
- checkSigTyVars [] (spec_tyvars ++ free_tyvars')
- spec_tau main_tau err_ctxt `thenTc_`
+ -- the type of the main function.
+ unifyTauTy sig_tau main_tau `thenTc_`
+ checkSigTyVars sig_tyvars sig_tau main_tau `thenTc_`
-- Check that the type variables of the polymorphic function are
-- either left polymorphic, or instantiate to ground type.
-- Also check that the overloaded type variables are instantiated to
-- ground type; or equivalently that all dictionaries have ground type
- applyTcSubstToTyVars main_tyvars `thenNF_Tc` \ main_arg_tys ->
- applyTcSubstToInsts main_dicts `thenNF_Tc` \ main_dicts' ->
-
- checkTc (not (all isGroundOrTyVarTy main_arg_tys))
- (specGroundnessErr err_ctxt main_arg_tys)
- `thenTc_`
+ mapTc zonkTcType main_arg_tys `thenNF_Tc` \ main_arg_tys' ->
+ zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' ->
+ tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
+ (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_`
+ tcAddErrCtxt (specContextGroundnessCtxt main_theta')
+ (checkTc (and [isGroundTy ty | (_,ty) <- theta'])) `thenTc_`
- checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType main_dicts']))
- (specCtxtGroundnessErr err_ctxt main_dicts')
- `thenTc_`
+ -- Build the SpecPragmaId; it is the thing that makes sure we
+ -- don't prematurely dead-code-eliminate the binding we are really interested in.
+ newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_pragma_id ->
-- Build a suitable binding; depending on whether we were given
-- a value (Maybe Name) to be used as the specialisation.
case using of
- Nothing ->
+ Nothing -> -- No implementation function specified
+
+ -- Make a Method inst for the occurrence of the overloaded function
+ newMethodWithGivenTy (OccurrenceOf name)
+ (TcId main_id) main_arg_tys main_rho `thenNF_Tc` \ (lie, meth_id) ->
- -- Make a specPragmaId to which to bind the new call-instance
- newSpecPragmaId name spec_ty Nothing
- `thenNF_Tc` \ pseudo_spec_id ->
let
- pseudo_bind = VarMonoBind pseudo_spec_id pseudo_rhs
- pseudo_rhs = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var main_id) main_arg_tys)
- (map mkInstId main_dicts'))
+ pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
+ pseudo_rhs = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
in
- returnTc (pseudo_bind, mkLIE main_dicts')
+ returnTc (pseudo_bind, lie, \ info -> info)
- Just spec_name -> -- use spec_name as the specialisation value ...
- let
- spec_id = lookupE_Value e spec_name
- spec_id_ty = getIdUniType spec_id
+ Just spec_name -> -- Use spec_name as the specialisation value ...
- spec_id_free_tyvars = extractTyVarsFromTy spec_id_ty
- spec_id_ctxt = ValSpecSpecIdCtxt name spec_ty spec_name src_loc
+ -- Type check a simple occurrence of the specialised Id
+ tcId spec_name `thenTc` \ (spec_body, spec_lie, spec_tau) ->
- spec_tys = map maybe_ty main_arg_tys
- maybe_ty ty | isTyVarTy ty = Nothing
- | otherwise = Just ty
- in
- -- Make an instance of the spec_id
- specTy origin spec_id_ty `thenNF_Tc` \ (spec_id_tyvars, spec_id_dicts, spec_id_tau) ->
-
- -- Check that the specialised type is indeed an instance of
- -- the type inferred for spec_id
- -- The unification should leave all type vars which are
- -- currently free in the environment still free, and likewise
- -- the signature type vars.
- -- The only way type vars free in the envt could possibly be affected
- -- is if spec_id_ty has free type variables. So we just extract them,
- -- and check that they are not constrained in any way by the unification.
- applyTcSubstAndCollectTyVars spec_id_free_tyvars `thenNF_Tc` \ spec_id_free_tyvars' ->
- unifyTauTy spec_tau spec_id_tau spec_id_ctxt `thenTc_`
- checkSigTyVars [] (spec_tyvars ++ spec_id_free_tyvars')
- spec_tau spec_id_tau spec_id_ctxt `thenTc_`
-
- -- Check that the type variables of the explicit spec_id are
- -- either left polymorphic, or instantiate to ground type.
- -- Also check that the overloaded type variables are instantiated to
- -- ground type; or equivalently that all dictionaries have ground type
- applyTcSubstToTyVars spec_id_tyvars `thenNF_Tc` \ spec_id_arg_tys ->
- applyTcSubstToInsts spec_id_dicts `thenNF_Tc` \ spec_id_dicts' ->
-
- checkTc (not (all isGroundOrTyVarTy spec_id_arg_tys))
- (specGroundnessErr spec_id_ctxt spec_id_arg_tys)
- `thenTc_`
-
- checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType spec_id_dicts']))
- (specCtxtGroundnessErr spec_id_ctxt spec_id_dicts')
- `thenTc_`
+ -- Check that it has the correct type, and doesn't constrain the
+ -- signature variables at all
+ unifyTauTy sig_tau spec_tau `thenTc_`
+ checkSigTyVars sig_tyvars sig_tau spec_tau `thenTc_`
-- Make a local SpecId to bind to applied spec_id
- newSpecId main_id spec_tys spec_ty `thenNF_Tc` \ local_spec_id ->
-
- -- Make a specPragmaId id with a spec_info for local_spec_id
- -- This is bound to local_spec_id
- -- The SpecInfo will be extracted by the specialiser and
- -- used to create a call instance for main_id (which is
- -- extracted from the spec_id)
- -- NB: the pseudo_local_id must stay in the scope of main_id !!!
- let
- spec_info = SpecInfo spec_tys (length main_dicts') local_spec_id
- in
- newSpecPragmaId name spec_ty (Just spec_info) `thenNF_Tc` \ pseudo_spec_id ->
+ newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id ->
+
let
- spec_bind = VarMonoBind local_spec_id spec_rhs
- spec_rhs = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var spec_id) spec_id_arg_tys)
- (map mkInstId spec_id_dicts'))
- pseudo_bind = VarMonoBind pseudo_spec_id (Var local_spec_id)
+ spec_rhs = mkHsTyLam sig_tyvars spec_body
+ spec_binds = VarMonoBind local_spec_id spec_rhs
+ `AndMonoBinds`
+ VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
+ spec_info = SpecInfo spec_tys (length main_theta) local_spec_id
in
- returnTc (spec_bind `AndMonoBinds` pseudo_bind, mkLIE spec_id_dicts')
- )
+ returnTc ((name, addInfo spec_info), spec_binds, spec_lie)
+-}
\end{code}
-\begin{code}
-tc_bind :: E
- -> RenamedBind
- -> TcM (TypecheckedBind, LIE)
-
-tc_bind e (NonRecBind mono_binds)
- = tcMonoBinds e mono_binds `thenTc` \ (mono_binds2, lie) ->
- returnTc (NonRecBind mono_binds2, lie)
-
-tc_bind e (RecBind mono_binds)
- = tcMonoBinds e mono_binds `thenTc` \ (mono_binds2, lie) ->
- returnTc (RecBind mono_binds2, lie)
-\end{code}
+Error contexts and messages
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-specialiseBinds
- :: [Id] -- Ids bound in this group
- -> LIE -- LIE of scope of these bindings
- -> TypecheckedBinds
- -> LIE
- -> NF_TcM (TypecheckedBinds, LIE)
-
-specialiseBinds bound_ids lie_of_scope poly_binds poly_lie
- = bindInstsOfLocalFuns lie_of_scope bound_ids
- `thenNF_Tc` \ (lie2, inst_mbinds) ->
-
- returnNF_Tc (poly_binds `ThenBinds` (SingleBind (NonRecBind inst_mbinds)),
- lie2 `plusLIE` poly_lie)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Signatures}
-%* *
-%************************************************************************
-
-@tcSigs@ checks the signatures for validity, and returns a list of
-{\em freshly-instantiated} signatures. That is, the types are already
-split up, and have fresh type variables (not @TyVarTemplate@s)
-installed.
-
-\begin{code}
-tcSigs :: E -> LVE
- -> [RenamedSig]
- -> TcM [SignatureInfo]
-
-tcSigs e lve [] = returnTc []
-
-tcSigs e lve (s:ss)
- = tc_sig s `thenTc` \ sig_info1 ->
- tcSigs e lve ss `thenTc` \ sig_info2 ->
- returnTc (sig_info1 : sig_info2)
+patMonoBindsCtxt bind sty
+ = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind)
+
+--------------------------------------------
+specContextGroundnessCtxt -- err_ctxt dicts sty
+ = panic "specContextGroundnessCtxt"
+{-
+ = ppHang (
+ ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
+ ppBesides [ppStr " specialised to the type `", ppr sty spec_ty, ppStr "'"],
+ pp_spec_id sty,
+ ppStr "... not all overloaded type variables were instantiated",
+ ppStr "to ground types:"])
+ 4 (ppAboves [ppCat [ppr sty c, ppr sty t]
+ | (c,t) <- map getDictClassAndType dicts])
where
- tc_sig (Sig v ty _ src_loc) -- no interesting pragmas on non-iface sigs
- = addSrcLocTc src_loc (
-
- babyTcMtoTcM
- (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
-
- let val = assoc "tcSigs" lve v in
- -- (The renamer/dependency-analyser should have ensured
- -- that there are only signatures for which there is a
- -- corresponding binding.)
-
- -- Instantiate the type, and unify with the type variable
- -- found in the Id.
- specTy SignatureOrigin sigma_ty `thenNF_Tc` \ (tyvars, dicts, tau_ty) ->
- unifyTauTy (getIdUniType val) tau_ty
- (panic "ToDo: unifyTauTy(tcSigs)") `thenTc_`
-
- returnTc (TySigInfo val tyvars dicts tau_ty src_loc)
- )
-
- tc_sig (SpecSig v ty using src_loc)
- = addSrcLocTc src_loc (
-
- babyTcMtoTcM
- (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
-
- returnTc (ValSpecInfo v sigma_ty using src_loc)
- )
+ (name, spec_ty, locn, pp_spec_id)
+ = case err_ctxt of
+ ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> ppNil)
+ ValSpecSpecIdCtxt n ty spec loc ->
+ (n, ty, loc,
+ \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
+-}
- tc_sig (InlineSig v guide locn)
- = returnTc (ValInlineInfo v guide locn)
+-----------------------------------------------
+specGroundnessCtxt
+ = panic "specGroundnessCtxt"
- tc_sig (DeforestSig v locn)
- = returnTc (ValDeforestInfo v locn)
- tc_sig (MagicUnfoldingSig v str locn)
- = returnTc (ValMagicUnfoldingInfo v str locn)
+valSpecSigCtxt v ty sty
+ = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:"))
+ 4 (ppSep [ppBeside (pprNonOp sty v) (ppPStr SLIT(" ::")),
+ ppr sty ty])
\end{code}
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcClassDcl where
-import Bag(Bag)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(Binds, MonoBinds)
-import HsDecls(ClassDecl)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import IdInfo(SpecEnv)
-import InstEnv(InstTemplate)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data ClassInfo
-tcClassDecls1 :: E -> (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) -> [ClassDecl Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([ClassInfo], UniqFM Class, [(Name, Id)])
-tcClassDecls2 :: E -> [ClassInfo] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, Binds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
#include "HsVersions.h"
module TcClassDcl (
- tcClassDecls1, tcClassDecls2,
- ClassInfo -- abstract
+ tcClassDecl1, tcClassDecls2
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty -- add proper one below
-
-import TcMonad -- typechecking monad machinery
-import TcMonadFns ( newDicts, newClassOpLocals, copyTyVars )
-import AbsSyn -- the stuff being typechecked
-
-import AbsPrel ( pAT_ERROR_ID )
-import AbsUniType ( mkClass, getClassKey, getClassBigSig,
- getClassOpString, getClassOps, splitType,
- mkSuperDictSelType, InstTyEnv(..),
- instantiateTy, instantiateThetaTy, UniType
- )
-import BackSubst ( applyTcSubstToBinds )
-import CE -- ( nullCE, unitCE, plusCE, CE(..), UniqFM )
-import E ( mkE, getE_TCE, getE_CE, tvOfE, nullGVE, plusGVE, E, TCE(..), UniqFM, GVE(..) )
-import Errors ( confusedNameErr, Error(..) )
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import Id ( mkSuperDictSelId, mkInstId, getIdUniType,
- Id, DictFun(..)
- )
-import IdInfo
-import Inst ( InstOrigin(..), Inst )
-import InstEnv
-import LIE ( nullLIE, mkLIE, plusLIE, LIE )
-import Maybes ( Maybe(..) )
-import Name ( Name(..) )
-import PlainCore ( escErrorMsg )
-import Spec ( specTy )
-import TVE ( mkTVE, TVE(..)
- IF_ATTACK_PRAGMAS(COMMA u2i)
- )
-import TcClassSig ( tcClassSigs )
-import TcContext ( tcContext )
+import Ubiq
+
+import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
+ Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
+ HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType,
+ Stmt, Qual, ArithSeqInfo, InPat, Fake )
+import HsPragmas ( ClassPragmas(..) )
+import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
+ RenamedClassOpSig(..), RenamedMonoBinds(..),
+ RenamedGenPragmas(..), RenamedContext(..) )
+import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
+ mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
+
+import TcMonad
+import GenSpecEtc ( specTy )
+import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
+import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
import TcInstDcls ( processInstBinds )
-import TcPragmas ( tcGenPragmas )
+import TcKind ( unifyKind )
+import TcMonoType ( tcMonoType, tcContext )
+import TcType ( TcTyVar(..), tcInstType, tcInstTyVar )
+import TcKind ( TcKind )
+
+import Bag ( foldBag )
+import Class ( GenClass, mkClass, mkClassOp, getClassBigSig,
+ getClassOps, getClassOpString, getClassOpLocalType )
+import CoreUtils ( escErrorMsg )
+import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
+ idType )
+import IdInfo ( noIdInfo )
+import Name ( Name, getNameFullName, getTagFromClassOpName )
+import PrelVals ( pAT_ERROR_ID )
+import PprStyle
+import Pretty
+import PprType ( GenType, GenTyVar, GenClassOp )
+import SpecEnv ( SpecEnv(..) )
+import SrcLoc ( mkGeneratedSrcLoc )
+import Type ( mkFunTy, mkTyVarTy, mkDictTy,
+ mkForAllTy, mkSigmaTy, splitSigmaTy)
+import TysWiredIn ( stringTy )
+import TyVar ( GenTyVar )
+import Unique ( Unique )
import Util
-\end{code}
-@ClassInfo@ communicates the essential information about
-locally-defined classes between passes 1 and 2.
+-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
+tcGenPragmas ty id ps = returnNF_Tc noIdInfo
+tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
-\begin{code}
-data ClassInfo
- = ClassInfo Class
- RenamedMonoBinds
\end{code}
+\begin{code}
+tcClassDecl1 rec_inst_mapper
+ (ClassDecl context class_name
+ tyvar_name class_sigs def_methods pragmas src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (classDeclCtxt class_name) $
+
+ -- LOOK THINGS UP IN THE ENVIRONMENT
+ tcLookupClass class_name `thenNF_Tc` \ (class_kind, rec_class) ->
+ tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
+ let
+ (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
+ in
+
+ -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
+ unifyKind class_kind tyvar_kind `thenTc_`
+
+ -- CHECK THE CONTEXT
+ tcClassContext rec_class rec_tyvar context pragmas
+ `thenTc` \ (scs, sc_sel_ids) ->
+
+ -- CHECK THE CLASS SIGNATURES,
+ mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
+ `thenTc` \ sig_stuff ->
+
+ -- MAKE THE CLASS OBJECT ITSELF
+ tcGetUnique `thenNF_Tc` \ uniq ->
+ let
+ (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
+ clas = mkClass uniq (getNameFullName class_name) rec_tyvar
+ scs sc_sel_ids ops op_sel_ids defm_ids
+ rec_class_inst_env
+ in
+ returnTc clas
+\end{code}
-%************************************************************************
-%* *
-\subsection[TcClassDcl]{Does the real work (apart from default methods)}
-%* *
-%************************************************************************
\begin{code}
-tcClassDecls1
- :: E -- Consult the CE/TCE args only to build knots
- -> InstanceMapper -- Maps class name to its instances,
- -- ...and its ops to their instances,
- -> [RenamedClassDecl]
- -> TcM ([ClassInfo], -- boiled-down info related to classes
- CE, -- env so we can look up classes elsewhere
- GVE) -- env so we can look up class ops elsewhere
-
-tcClassDecls1 e rec_inst_mapper []
- = returnTc ([], nullCE, nullGVE)
-
-tcClassDecls1 e rec_inst_mapper (cd:cds)
- = tc_clas1 cd `thenTc` \ (cinfo1_maybe, ce1, gve1) ->
- tcClassDecls1 e rec_inst_mapper cds `thenTc` \ (cinfo2, ce2, gve2) ->
+tcClassContext :: Class -> TyVar
+ -> RenamedContext -- class context
+ -> RenamedClassPragmas -- pragmas for superclasses
+ -> TcM s ([Class], -- the superclasses
+ [Id]) -- superclass selector Ids
+
+tcClassContext rec_class rec_tyvar context pragmas
+ = -- Check the context.
+ -- The renamer has already checked that the context mentions
+ -- only the type variable of the class decl.
+ tcContext context `thenTc` \ theta ->
let
- glued_cinfos
- = case cinfo1_maybe of
- Nothing -> cinfo2
- Just xx -> xx : cinfo2
+ super_classes = [ supers | (supers, _) <- theta ]
in
- returnTc (glued_cinfos, ce1 `plusCE` ce2, gve1 `plusGVE` gve2)
+
+ -- Make super-class selector ids
+ mapTc (mk_super_id rec_class)
+ (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids ->
+
+ -- Done
+ returnTc (super_classes, sc_sel_ids)
+
where
- rec_ce = getE_CE e
- rec_tce = getE_TCE e
+ mk_super_id rec_class (super_class, maybe_pragma)
+ = fixTc ( \ rec_super_id ->
+ tcGetUnique `thenNF_Tc` \ uniq ->
+
+ -- GET THE PRAGMA INFO FOR THE SUPERCLASS
+ (case maybe_pragma of
+ Nothing -> returnNF_Tc noIdInfo
+ 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))
+ )
+ in
+ -- BUILD THE SUPERCLASS ID
+ returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
+ )
+
+ maybe_pragmas :: [Maybe RenamedGenPragmas]
+ maybe_pragmas = case pragmas of
+ NoClassPragmas -> repeat Nothing
+ SuperDictPragmas prags -> ASSERT(length prags == length context)
+ map Just prags
+ -- If there are any pragmas there should
+ -- be one for each superclass
+
+
+
+tcClassSig :: Class -- Knot tying only!
+ -> TyVar -- The class type variable, used for error check only
+ -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
+ -> RenamedClassOpSig
+ -> TcM s (ClassOp, -- class op
+ Id, -- selector id
+ Id) -- default-method ids
+
+tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
+ (ClassOpSig op_name
+ (HsForAllTy tyvar_names context monotype)
+ 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) ->
+ 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
+ class_op = mkClassOp (getOccurrenceName op_name)
+ (getTagFromClassOpName op_name)
+ local_ty
+ in
- tc_clas1 (ClassDecl context class_name
- tyvar_name class_sigs def_methods pragmas src_loc)
+ -- Munch the pragmas
+ tcClassOpPragmas
+ global_ty
+ rec_sel_id rec_defm_id
+ (rec_classop_spec_fn class_op)
+ pragmas `thenNF_Tc` \ (op_info, defm_info) ->
- = addSrcLocTc src_loc (
-
- -- The knot is needed so that the signatures etc can point
- -- back to the class itself
- fixTc (\ ~(rec_clas, _) ->
- let
- (rec_clas_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_clas
- in
- -- Get new (template) type variables for the class
- let (tve, [clas_tyvar], [alpha]) = mkTVE [tyvar_name] in
-
- -- Typecheck the class context; since there is only one type
- -- variable in scope, we are assured that the it will be of
- -- the form (C1 a, C2 a...)
- babyTcMtoTcM (tcContext rec_ce rec_tce tve context) `thenTc` \ theta ->
-
- -- Make the superclass selector ids; the "class" pragmas
- -- may have info about the superclass dict selectors;
- -- so it is only tcClassPragmas that gives back the
- -- final Ids.
- getUniquesTc (length theta) `thenNF_Tc` \ uniqs ->
- let
- super_classes = [ supers | (supers, _) <- theta ]
- super_tys
- = [ mkSuperDictSelType rec_clas super | super <- super_classes ]
- super_info = zip3 super_classes uniqs super_tys
- in
- (case pragmas of
- NoClassPragmas ->
- returnNF_Tc [ mk_super_id rec_clas info noIdInfo | info <- super_info ]
-
- SuperDictPragmas prags ->
--- pprTrace "SuperDictPragmas:" (ppAboves (ppr PprDebug prags : map pp super_info)) (
- mapNF_Tc (mk_super_id_w_info rec_clas) (super_info `zipEqual` prags)
--- )
--- where
--- pp (sc, u, ty) = ppCat [ppr PprDebug sc, ppr PprDebug ty]
-
- ) `thenNF_Tc` \ super_class_sel_ids ->
-
- -- Typecheck the class signatures, checking that each mentions
- -- the class type variable somewhere, and manufacturing
- -- suitable Ids for selectors and default methods.
- babyTcMtoTcM
- (tcClassSigs e tve rec_clas rec_class_op_inst_fn
- clas_tyvar defm_names class_sigs)
- `thenTc` \ (ops, ops_gve, op_sel_ids, defm_ids) ->
-
- -- Make the class object itself, producing clas::Class
- let
- clas
- = mkClass class_name clas_tyvar
- super_classes super_class_sel_ids
- ops op_sel_ids defm_ids
- rec_clas_inst_env
- in
- returnTc (clas, ops_gve)
- ) `thenTc` \ (clas, ops_gve) ->
-
- -- Return the class decl for further work if it is
- -- local, otherwise just return the CE
- returnTc (if (isLocallyDefined class_name) then
- Just (ClassInfo clas def_methods)
- else
- Nothing,
- unitCE (getClassKey clas) clas,
- ops_gve
- ))
- where
- defm_names = collectMonoBinders def_methods
-
- -----------
- mk_super_id clas (super_clas, uniq, ty) id_info
- = mkSuperDictSelId uniq clas super_clas ty id_info
-
- -----------
- mk_super_id_w_info clas ((super_clas, uniq, ty), gen_prags)
- = fixNF_Tc ( \ rec_super_id ->
- babyTcMtoNF_TcM
- (tcGenPragmas e{-fake_E-} Nothing{-ty unknown-} rec_super_id gen_prags)
- `thenNF_Tc` \ id_info ->
-
- returnNF_Tc(mkSuperDictSelId uniq clas super_clas ty id_info)
- )
-
-{- SOMETHING LIKE THIS NEEDED? ToDo [WDP]
- tc_clas1 (ClassDecl _ bad_name _ _ _ _ src_loc)
- = failTc (confusedNameErr
- "Bad name for a class (a type constructor, or Prelude name?)"
- bad_name src_loc)
--}
+ -- Build the selector id and default method id
+ tcGetUnique `thenNF_Tc` \ d_uniq ->
+ let
+ op_uniq = getItsUnique op_name
+ sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info
+ defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info
+ -- ToDo: improve the "False"
+ in
+ returnTc (class_op, sel_id, defm_id)
+ )
\end{code}
(Omitted ones elicit an error message.)
\item
to produce a definition for the selector function for each method
+and superclass dictionary.
\end{enumerate}
Pass~2 only applies to locally-defined class declarations.
-The function @tcClassDecls2@ just arranges to apply
-@tcClassDecls2_help@ to each local class decl.
+The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
+each local class decl.
\begin{code}
-tcClassDecls2 e class_info
- = let
- -- Get type variables free in environment. Sadly, there may be
- -- some, because of the dreaded monomorphism restriction
- free_tyvars = tvOfE e
- in
- tcClassDecls2_help e free_tyvars class_info
-
-tcClassDecls2_help
- :: E
- -> [TyVar]
- -> [ClassInfo]
- -> NF_TcM (LIE, TypecheckedBinds)
-
-tcClassDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
-
-tcClassDecls2_help e free_tyvars ((ClassInfo clas default_binds) : rest)
- = tcClassDecl2 e free_tyvars clas default_binds `thenNF_Tc` \ (lie1, binds1) ->
- tcClassDecls2_help e free_tyvars rest `thenNF_Tc` \ (lie2, binds2) ->
- returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
+tcClassDecls2 :: Bag RenamedClassDecl
+ -> NF_TcM s (LIE s, TcHsBinds s)
+
+tcClassDecls2 decls
+ = foldBag combine
+ tcClassDecl2
+ (returnNF_Tc (emptyLIE, EmptyBinds))
+ decls
+ where
+ combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
+ tc2 `thenNF_Tc` \ (lie2, binds2) ->
+ returnNF_Tc (lie1 `plusLIE` lie2,
+ binds1 `ThenBinds` binds2)
\end{code}
@tcClassDecl2@ is the business end of things.
\begin{code}
-tcClassDecl2 :: E
- -> [TyVar] -- Free in the envt
- -> Class
- -> RenamedMonoBinds -- The default decls
- -> NF_TcM (LIE, TypecheckedBinds)
-
-tcClassDecl2 e free_tyvars clas default_binds
- = let
- src_loc = getSrcLoc clas
- origin = ClassDeclOrigin src_loc
- (clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
+tcClassDecl2 :: RenamedClassDecl -- The class declaration
+ -> NF_TcM s (LIE s, TcHsBinds s)
+
+tcClassDecl2 (ClassDecl context class_name
+ tyvar_name class_sigs default_binds pragmas src_loc)
+ = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
+ tcAddSrcLoc src_loc $
+
+ -- Get the relevant class
+ tcLookupClass class_name `thenNF_Tc` \ (_, clas) ->
+ let
+ (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
= getClassBigSig clas
in
- -- Prune the substitution when we are finished, and arrange error recovery
- recoverTc (nullLIE, EmptyBinds) (
- addSrcLocTc src_loc (
- pruneSubstTc free_tyvars (
+ tcInstTyVar tyvar `thenNF_Tc` \ clas_tyvar ->
- -- Generate bindings for the selector functions
- buildSelectors origin clas clas_tyvar_tmpl scs sc_sel_ids ops op_sel_ids
+ -- Generate bindings for the selector functions
+ buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
`thenNF_Tc` \ sel_binds ->
- -- Ditto for the methods
- buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
- defm_ids default_binds `thenTc` \ (const_insts, meth_binds) ->
-
- -- Back-substitute through the definitions
- applyTcSubstToInsts const_insts `thenNF_Tc` \ final_const_insts ->
- applyTcSubstToBinds (sel_binds `ThenBinds` meth_binds) `thenNF_Tc` \ final_binds ->
- returnTc (mkLIE final_const_insts, final_binds)
- )))
+ -- Ditto for the methods
+ buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
+ `thenTc` \ (const_insts, meth_binds) ->
+
+ returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-buildSelectors :: InstOrigin
- -> Class -- The class object
- -> TyVarTemplate -- Class type variable
+buildSelectors :: Class -- The class object
+ -> TcTyVar s -- Class type variable
-> [Class] -> [Id] -- Superclasses and selectors
-> [ClassOp] -> [Id] -- Class ops and selectors
- -> NF_TcM TypecheckedBinds
+ -> NF_TcM s (TcHsBinds s)
-buildSelectors origin clas clas_tyvar_tmpl
- scs sc_sel_ids
- ops op_sel_ids
+buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
=
- -- Instantiate the class variable
- copyTyVars [clas_tyvar_tmpl] `thenNF_Tc` \ (inst_env, [clas_tyvar], [clas_tyvar_ty]) ->
- -- Make an Inst for each class op, and
- -- dicts for the superclasses. These are used to
- -- construct the selector functions
- newClassOpLocals inst_env ops `thenNF_Tc` \ method_ids ->
- newDicts origin [ (super_clas, clas_tyvar_ty)
- | super_clas <- scs
- ] `thenNF_Tc` \ dicts ->
- let dict_ids = map mkInstId dicts in
+ -- Make new Ids for the components of the dictionary
+ mapNF_Tc (tcInstType [] . getClassOpLocalType) ops `thenNF_Tc` \ op_tys ->
+
+ newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids ->
+
+ newDicts ClassDeclOrigin
+ [ (super_clas, mkTyVarTy clas_tyvar)
+ | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) ->
+
+ newDicts ClassDeclOrigin
+ [ (clas, mkTyVarTy clas_tyvar) ] `thenNF_Tc` \ (_,[clas_dict]) ->
-- Make suitable bindings for the selectors
- let mk_op_sel op sel_id method_id
- = mkSelExpr origin clas_tyvar dict_ids method_ids method_id `thenNF_Tc` \ rhs ->
- returnNF_Tc (VarMonoBind sel_id rhs)
- mk_sc_sel sc sel_id dict_id
- = mkSelExpr origin clas_tyvar dict_ids method_ids dict_id `thenNF_Tc` \ rhs ->
- returnNF_Tc (VarMonoBind sel_id rhs)
+ let
+ tc_method_ids = map TcId method_ids
+
+ mk_sel sel_id method_or_dict
+ = mkSelBind sel_id clas_tyvar clas_dict dict_ids tc_method_ids method_or_dict
in
- listNF_Tc (zipWith3 mk_op_sel ops op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
- listNF_Tc (zipWith3 mk_sc_sel scs sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
+ listNF_Tc (zipWithEqual mk_sel op_sel_ids tc_method_ids) `thenNF_Tc` \ op_sel_binds ->
+ listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
returnNF_Tc (SingleBind (
NonRecBind (
- foldr AndMonoBinds EmptyMonoBinds (
- op_sel_binds ++ sc_sel_binds))))
+ foldr AndMonoBinds
+ (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
+ sc_sel_binds
+ )))
\end{code}
%************************************************************************
%* *
%************************************************************************
-Make a selector expression for @local@ from a dictionary consisting of
-@dicts@ and @op_locals@.
+Make a selector expression for @sel_id@ from a dictionary @clas_dict@
+consisting of @dicts@ and @methods@.
We have to do a bit of jiggery pokery to get the type variables right.
Suppose we have the class decl:
\end{verbatim}
Then the method selector for \tr{op1} is like this:
\begin{verbatim}
- op1_sel = /\ab -> \dFoo -> case dFoo of
- (op1_method,op2_method) -> op1_method b
+ op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
+ (op1_method,op2_method) -> op1_method b dOrd
\end{verbatim}
-Note that the type variable for \tr{b} is lifted to the top big lambda, and
-\tr{op1_method} is applied to it. This is preferable to the alternative:
+Note that the type variable for \tr{b} and the (Ord b) dictionary
+are lifted to the top lambda, and
+\tr{op1_method} is applied to them. This is preferable to the alternative:
\begin{verbatim}
op1_sel' = /\a -> \dFoo -> case dFoo of
(op1_method,op2_method) -> op1_method
op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
\end{verbatim}
-{\em NOTE:}
-We could do the same thing for the dictionaries, giving
-\begin{verbatim}
- op1_sel = /\ab -> \dFoo -> \dOrd -> case dFoo of
- (m1,m2) -> m1 b dOrd
-\end{verbatim}
-but WE ASSUME THAT DICTIONARY APPLICATION IS CURRIED, so the two are
-precisely equivalent, and have the same type, namely
-\begin{verbatim}
- op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
-\end{verbatim}
+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!
-WDP 95/03: Quite false (``DICTIONARY APPLICATION IS CURRIED'').
-Specialisation now wants to see all type- and dictionary-applications
-absolutely explicitly.
+NOTE ALSO that the selector has no free type variables, so we
+don't bother to instantiate the class-op's local type; instead
+we just use the variables inside it.
\begin{code}
-mkSelExpr :: InstOrigin -> TyVar -> [Id] -> [Id] -> Id -> NF_TcM TypecheckedExpr
+mkSelBind :: Id -- the selector id
+ -> TcTyVar s -> TcIdOcc s -- class tyvar and dict
+ -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
+ -> TcIdOcc s -- the superclass/method being slected
+ -> NF_TcM s (TcMonoBinds s)
-mkSelExpr origin clas_tyvar dicts op_locals local
+mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
= let
- (op_tyvar_tmpls,local_theta,_) = splitType (getIdUniType local)
- in
- copyTyVars op_tyvar_tmpls `thenNF_Tc` \ (inst_env, op_tyvars, tys) ->
- let
- inst_theta = instantiateThetaTy inst_env local_theta
- in
- newDicts origin inst_theta `thenNF_Tc` \ local_dict_insts ->
- let
- local_dicts = map mkInstId local_dict_insts
+ (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
+ op_tys = map mkTyVarTy op_tyvars
in
- returnNF_Tc (TyLam (clas_tyvar:op_tyvars)
- (ClassDictLam
- dicts
- op_locals
- (mkDictLam local_dicts
- (mkDictApp (mkTyApp (Var local) tys) local_dicts))))
+ newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) ->
+
+ -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
+ -- case clas_dict of
+ -- <dicts..methods> -> method_or_dict op_tyvars op_dicts
+
+ returnNF_Tc (VarMonoBind (RealId sel_id) (
+ TyLam (clas_tyvar:op_tyvars) (
+ DictLam (clas_dict:op_dicts) (
+ HsCase
+ (HsVar clas_dict)
+ ([PatMatch (DictPat dicts methods) (
+ GRHSMatch (GRHSsAndBindsOut
+ [OtherwiseGRHS
+ (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
+ mkGeneratedSrcLoc]
+ EmptyBinds
+ op_tau))])
+ mkGeneratedSrcLoc
+ ))))
\end{code}
\begin{code}
buildDefaultMethodBinds
- :: E
- -> [TyVar]
- -> InstOrigin
- -> Class
- -> TyVarTemplate
+ :: Class
+ -> TcTyVar s
-> [Id]
-> RenamedMonoBinds
- -> TcM ([Inst], TypecheckedBinds)
+ -> TcM s (LIE s, TcHsBinds s)
-buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
+buildDefaultMethodBinds clas clas_tyvar
default_method_ids default_binds
= -- Deal with the method declarations themselves
- processInstBinds e
- free_tyvars
- (makeClassDeclDefaultMethodRhs clas origin default_method_ids)
- [] -- No tyvars in scope for "this inst decl"
- [] -- No insts available
- default_method_ids
+ mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids ->
+ processInstBinds
+ (makeClassDeclDefaultMethodRhs clas default_method_ids)
+ [] -- No tyvars in scope for "this inst decl"
+ emptyLIE -- No insts available
+ (map TcId tc_defm_ids)
default_binds `thenTc` \ (dicts_needed, default_binds') ->
returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
\begin{code}
makeClassDeclDefaultMethodRhs
:: Class
- -> InstOrigin
-> [Id]
-> Int
- -> NF_TcM TypecheckedExpr
+ -> NF_TcM s (TcExpr s)
-makeClassDeclDefaultMethodRhs clas origin method_ids tag
- = specTy origin (getIdUniType method_id) `thenNF_Tc` \ (tyvars, dicts, tau) ->
+makeClassDeclDefaultMethodRhs clas method_ids tag
+ = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) ->
- returnNF_Tc (mkTyLam tyvars (
- mkDictLam (map mkInstId dicts) (
- App (mkTyApp (Var pAT_ERROR_ID) [tau])
- (Lit (StringLit (_PK_ error_msg))))))
+ returnNF_Tc (mkHsTyLam tyvars (
+ mkHsDictLam dict_ids (
+ HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
+ (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
where
+ (clas_mod, clas_name) = getOrigName clas
+
method_id = method_ids !! (tag-1)
class_op = (getClassOps clas) !! (tag-1)
_UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
++ (ppShow 80 (ppr PprForUser class_op))
++ "\"" )
+\end{code}
- (clas_mod, clas_name) = getOrigName clas
+
+Contexts
+~~~~~~~~
+\begin{code}
+classDeclCtxt class_name sty
+ = ppCat [ppStr "In the class declaration for", ppr sty class_name]
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcClassSig where
-import Bag(Bag)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(Sig)
-import Id(Id)
-import IdInfo(SpecEnv)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcClassSigs :: E -> UniqFM UniType -> Class -> (ClassOp -> SpecEnv) -> TyVarTemplate -> [Name] -> [Sig Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ([ClassOp], [(Name, Id)], [Id], [Id])
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcClassSig]{Typecheck a class signature}
module TcClassSig ( tcClassSigs ) where
import TcMonad -- typechecking monadic machinery
-import AbsSyn -- the stuff being typechecked
+import HsSyn -- the stuff being typechecked
-import AbsUniType
-import CE ( CE(..) )
-import E ( mkE, getE_TCE, getE_CE, nullGVE, unitGVE, plusGVE, GVE(..), E )
-import Errors ( methodTypeLacksTyVarErr, confusedNameErr )
+import Type
import Id ( mkDefaultMethodId, mkClassOpId, IdInfo )
import IdInfo
-import InstEnv ( InstTemplate )
-import TCE ( TCE(..), UniqFM )
-import TVE ( TVE(..) )
-import TcPolyType ( tcPolyType )
+import TcMonoType ( tcPolyType )
import TcPragmas ( tcClassOpPragmas )
import Util
\end{code}
-> [Name] -- Names with default methods
-> [RenamedClassOpSig]
-> Baby_TcM ([ClassOp], -- class ops
- GVE, -- env for looking up the class ops
- [Id], -- selector ids
- [Id]) -- default-method ids
+ GVE, -- env for looking up the class ops
+ [Id], -- selector ids
+ [Id]) -- default-method ids
tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar defm_names sigs
= mapB_Tc tc_sig sigs `thenB_Tc` \ stuff ->
where
rec_ce = getE_CE e
rec_tce = getE_TCE e
+--FAKE: fake_E = mkE rec_tce rec_ce
- tc_sig (ClassOpSig name@(ClassOpName op_uniq clas_name op_name tag) poly_ty pragmas src_loc)
+ tc_sig (ClassOpSig name@(ClassOpName op_uniq _ op_name tag) poly_ty pragmas src_loc)
= addSrcLocB_Tc src_loc (
tcPolyType rec_ce rec_tce tve poly_ty `thenB_Tc` \ local_ty ->
let
- (local_tyvar_tmpls, theta, tau) = splitType local_ty
+ (local_tyvar_tmpls, theta, tau) = splitSigmaTy local_ty
full_theta = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta
full_tyvar_tmpls = clas_tyvar : local_tyvar_tmpls
global_ty = mkForallTy full_tyvar_tmpls (mkRhoTy full_theta tau)
-- default method code or the imported default method is bottoming.
error_defm = if isLocallyDefined clas_name then
- name `notElem` defm_names
- else
+ name `notElem` defm_names
+ else
bottomIsGuaranteed (getInfo defm_info)
in
returnB_Tc (
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcConDecls where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import HsDecls(ConDecl)
-import Id(Id)
-import IdInfo(SpecEnv)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcConDecls :: UniqFM TyCon -> UniqFM UniType -> TyCon -> [TyVarTemplate] -> SpecEnv -> [ConDecl Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Name, Id)]
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcConDecls]{Typechecking @ConDecls@}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcConDecls ( tcConDecls ) where
-
-import TcMonad -- typechecking monadic machinery
-import AbsSyn
-
-import CE ( CE(..) )
-import E ( GVE(..), nullGVE, plusGVE )
-import Errors ( confusedNameErr )
-import Id ( mkDataCon, SpecEnv )
-import TCE ( TCE(..), UniqFM )
-import TVE ( TVE(..) )
-import TcMonoType ( tcMonoType )
-import Util
-\end{code}
-
-\begin{code}
-tcConDecls :: TCE -> TVE -> TyCon -> [TyVarTemplate] -> SpecEnv
- -> [RenamedConDecl] -> Baby_TcM GVE
-
-tcConDecls tce tve tycon tyvars specenv [] = returnB_Tc nullGVE
-
-tcConDecls tce tve tycon tyvars specenv (cd:cds)
- = tc_decl cd `thenB_Tc` \ gve_fst ->
- tcConDecls tce tve tycon tyvars specenv cds `thenB_Tc` \ gve_rest ->
- returnB_Tc (plusGVE gve_fst gve_rest)
- where
- tc_decl (ConDecl name@(OtherTopId uniq full_name) tys src_loc)
- = addSrcLocB_Tc src_loc (
- mapB_Tc (tcMonoType fake_CE tce tve) tys `thenB_Tc` \ arg_tys ->
- returnB_Tc [(name, data_con arg_tys)]
- )
- where
- fake_CE = panic "tcConDecls:CE"
-
- data_con arg_tys
- = mkDataCon uniq
- full_name
- tyvars
- [{-no context-}]
- arg_tys
- tycon
- specenv
-
- tc_decl (ConDecl odd_name _ src_loc)
- = failB_Tc (confusedNameErr "Bad name for a data constructor (a Prelude name?)"
- odd_name src_loc)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcContext where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcContext :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> [(Name, Name)] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Class, UniType)]
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcContext]{Typecheck a type-class context}
-
-\begin{code}
-module TcContext ( tcContext ) where
-
-#include "HsVersions.h"
-
-import TcMonad -- typechecking monadic machinery
-import AbsSyn -- the stuff being typechecked
-
-import CE ( lookupCE, CE(..) )
-import Errors ( naughtyCCallContextErr )
-import TCE ( TCE(..), UniqFM )
-import TVE ( TVE(..) )
-import TcMonoType ( tcMonoType )
-import Unique ( cCallableClassKey, cReturnableClassKey )
-import Util
-
-tcContext :: CE -> TCE -> TVE -> RenamedContext -> Baby_TcM ThetaType
-
-tcContext ce tce tve context
- = mapB_Tc (tcClassAssertion ce tce tve) context
-
-tcClassAssertion ce tce tve (class_name, tyname)
- | canBeUsedInContext class_name
- = tcMonoType ce tce tve (MonoTyVar tyname) `thenB_Tc` \ ty ->
- returnB_Tc (lookupCE ce class_name, ty)
-
- | otherwise
- = getSrcLocB_Tc `thenB_Tc` \ locn ->
- failB_Tc (naughtyCCallContextErr class_name locn)
-\end{code}
-
-HACK warning: Someone discovered that @_CCallable_@ and @_CReturnable@
-could be used in contexts such as:
-\begin{verbatim}
-foo :: _CCallable a => a -> PrimIO Int
-\end{verbatim}
-
-Doing this utterly wrecks the whole point of introducing these
-classes so we specifically check that this isn't being done.
-
-\begin{code}
-canBeUsedInContext :: Name -> Bool
-
-canBeUsedInContext class_name
- = class_name /= cCallableClass && class_name /= cReturnableClass
- where
- cCallableClass = PreludeClass cCallableClassKey bottom
- cReturnableClass = PreludeClass cReturnableClassKey bottom
- bottom = panic "canBeUsedInContext"
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcDefaults where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsDecls(DefaultDecl)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcDefaults :: E -> [DefaultDecl Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [UniType]
-
module TcDefaults ( tcDefaults ) where
-import TcMonad
-import AbsSyn
+import Ubiq
+
+import HsSyn ( DefaultDecl(..), MonoType,
+ HsExpr, HsLit, ArithSeqInfo, Fake, InPat)
+import RnHsSyn ( RenamedDefaultDecl(..) )
+import TcHsSyn ( TcIdOcc )
-import AbsPrel ( intTy, doubleTy, unitTy )
-import AbsUniType ( UniType
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import CE ( lookupCE, CE(..) )
-import E
-import Inst
-import Name
+import TcMonad
+import Inst ( InstOrigin(..) )
+import TcEnv ( tcLookupClassByKey )
import TcMonoType ( tcMonoType )
import TcSimplify ( tcSimplifyCheckThetas )
-import TVE
-import Unique ( numClassKey, Unique )
+
+import PrelInfo ( intTy, doubleTy, unitTy )
+import Unique ( numClassKey )
import Util
\end{code}
\begin{code}
-tcDefaults :: E
- -> [RenamedDefaultDecl]
- -> TcM [UniType] -- defaulting types to heave
+tcDefaults :: [RenamedDefaultDecl]
+ -> TcM s [Type] -- defaulting types to heave
-- into Tc monad for later use
-- in Disambig.
-tcDefaults _ []
- = returnTc [intTy, doubleTy] -- language-specified default `default'
+tcDefaults []
+ = returnTc [intTy, doubleTy] -- language-specified default `default'
-tcDefaults e [DefaultDecl mono_tys locn]
- = let
- ce = getE_CE e
- tce = getE_TCE e
- tve = nullTVE
+tcDefaults [DefaultDecl mono_tys locn]
+ = tcAddSrcLoc locn $
+ mapTc tcMonoType mono_tys `thenTc` \ tau_tys ->
- num_clas = lookupCE ce (PreludeClass numClassKey (panic "tcDefaults"))
- in
- babyTcMtoTcM (mapB_Tc (tcMonoType ce tce tve) mono_tys) `thenTc` \ tau_tys ->
-
- -- compensate for extreme parser hack: `default ()' actually
- -- sends the *type* () through to here. Squash it.
case tau_tys of
- [ty] | ty == unitTy -> returnTc []
-
- _ -> -- (Back to your regularly scheduled programming...)
+ [] -> returnTc [] -- no defaults
+ _ ->
-- Check that all the types are instances of Num
-
- tcSimplifyCheckThetas (DefaultDeclOrigin locn)
- [ (num_clas, ty) | ty <- tau_tys ] `thenTc` \ _ ->
-- We only care about whether it worked or not
- returnTc tau_tys -- caller will bung them into Tc monad
+ tcLookupClassByKey numClassKey `thenNF_Tc` \ num ->
+ tcSimplifyCheckThetas DefaultDeclOrigin
+ [ (num, ty) | ty <- tau_tys ] `thenTc` \ _ ->
+
+ returnTc tau_tys
-tcDefaults _ (_:_)
- = error "ERROR: You can only have one `default' declaration per module."
- -- ToDo: proper error msg.
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcDeriv where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import HsBinds(Binds)
-import HsDecls(FixityDecl)
-import HsPat(InPat)
-import Maybes(Labda)
-import Name(Name)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import ProtoName(ProtoName)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcInstDcls(InstInfo)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-type DerivEqn = (Class, TyCon, [TyVar], [(Class, UniType)])
-data TagThingWanted = GenCon2Tag | GenTag2Con | GenMaxTag
-con2tag_PN :: TyCon -> ProtoName
-maxtag_PN :: TyCon -> ProtoName
-tag2con_PN :: TyCon -> ProtoName
-tcDeriving :: _PackedString -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Bag InstInfo -> UniqFM TyCon -> [FixityDecl Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Bag InstInfo, Binds Name (InPat Name), PprStyle -> Int -> Bool -> PrettyRep)
-
Handles @deriving@ clauses on @data@ declarations.
-********** Don't forget
-
-Multi-instance checking in renamer should include deriving.
-
\begin{code}
#include "HsVersions.h"
module TcDeriv (
- tcDeriving,
- con2tag_PN, tag2con_PN, maxtag_PN,
- TagThingWanted(..), DerivEqn(..)
+ tcDeriving
) where
-IMPORT_Trace -- ToDo:rm debugging
-import Outputable
-import Pretty
+import Ubiq
+
+import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
+ GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
+ ArithSeqInfo, Fake, MonoType )
+import HsPragmas ( InstancePragmas(..) )
+import RnHsSyn ( RenamedHsBinds(..), RenamedFixityDecl(..) )
+import TcHsSyn ( TcIdOcc )
+
+import TcMonad
+import Inst ( InstOrigin(..), InstanceMapper(..) )
+import TcEnv ( getEnv_TyCons )
+import TcGenDeriv -- Deriv stuff
+import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
+import TcSimplify ( tcSimplifyThetas )
-import TcMonad -- typechecking monad machinery
-import TcMonadFns ( copyTyVars )
-import AbsSyn -- the stuff being typechecked
-import TcGenDeriv -- support code that generates all the grimy bindings
- -- for derived instance decls.
-
-import AbsPrel ( mkFunTy )
-import AbsUniType
-import UniType ( UniType(..) ) -- *********** CHEATING!!! ****************
-import Bag
-import CE ( CE(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import E ( E )
-import Errors
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- InstancePragmas(..)
-import Id ( getDataConSig, isNullaryDataCon, DataCon(..) )
-import IdInfo
-import Inst ( InstOrigin(..) )
-import InstEnv
+import RnMonad4
+import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+import RnBinds4 ( rnMethodBinds, rnTopBinds )
+
+import Bag ( Bag, isEmptyBag, unionBags, listToBag )
+import Class ( GenClass, getClassKey )
+import ErrUtils ( pprBagOfErrors, addErrLoc, TcError(..) )
+import Id ( getDataConSig, getDataConArity )
import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import NameTypes ( mkFullName, mkPreludeCoreName,
- Provenance(..), FullName, ShortName
- )
+import Name ( Name(..) )
+import NameTypes ( mkPreludeCoreName, Provenance(..) )
+import Outputable
+import PprType ( GenType, GenTyVar, GenClass, TyCon )
+import PprStyle
+import Pretty
import ProtoName ( eqProtoName, ProtoName(..), Name )
-import RenameAuxFuns -- why not? take all of it...
-import RenameBinds4 ( rnMethodBinds4, rnTopBinds4 )
-import RenameMonad4 -- initRn4, etc.
import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import TCE -- ( rngTCE, TCE(..), UniqFM )
-import TcInstDcls ( InstInfo(..), buildInstanceEnvs, mkInstanceRelatedIds )
-import TcSimplify ( tcSimplifyThetas )
-import Unique -- *Key stuff
-import Util
+import TyCon ( getTyConTyVars, getTyConDataCons, getTyConDerivings,
+ maybeTyConSingleCon, isEnumerationTyCon, TyCon )
+import Type ( GenType(..), TauType(..), mkTyVarTy, applyTyCon,
+ mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
+ getAppTyCon, getAppDataTyCon )
+import TyVar ( GenTyVar )
+import UniqFM ( eltsUFM )
+import Unique -- Keys stuff
+import Util ( zipWithEqual, zipEqual, sortLt, removeDups,
+ thenCmp, cmpList, panic, pprPanic, pprPanic# )
\end{code}
%************************************************************************
Consider
- data T a b = C1 (Foo a) (Bar b)
- | C2 Int (T b a)
+ data T a b = C1 (Foo a) (Bar b)
+ | C2 Int (T b a)
| C3 (T a a)
deriving (Eq)
u Eq (T a a) -- From C3
After simplification:
- = Eq a u Ping b
+ = Eq a u Ping b
u (Eq b u Ping a)
u (Eq a u Ping a)
-
+
= Eq a u Ping b u Eq b u Ping a
The next iteration gives the same result, so this is the fixpoint. We
\begin{code}
tcDeriving :: FAST_STRING -- name of module under scrutiny
- -> GlobalNameFuns -- for "renaming" bits of generated code
+ -> GlobalNameMappers -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
- -> TCE -- All known TyCon info
- -> [RenamedFixityDecl] -- Fixity info; may be used for Text
- -> TcM (Bag InstInfo, -- The generated "instance decls".
- RenamedBinds, -- Extra generated bindings
- PprStyle -> Pretty) -- Printable derived instance decls;
- -- for debugging via -ddump-derivings.
-
-tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities
- = -- Fish the "deriving"-related information out of the TCE,
- -- from which we make the necessary "equations".
- makeDerivEqns tce `thenTc` \ eqns ->
+ -> [RenamedFixityDecl] -- Fixity info; used by Read and Show
+ -> TcM s (Bag InstInfo, -- The generated "instance decls".
+ RenamedHsBinds, -- Extra generated bindings
+ PprStyle -> Pretty) -- Printable derived instance decls;
+ -- for debugging via -ddump-derivings.
+
+tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
+ = -- Fish the "deriving"-related information out of the TcEnv
+ -- and make the necessary "equations".
+ makeDerivEqns `thenTc` \ eqns ->
-- Take the equation list and solve it, to deliver a list of
-- solutions, a.k.a. the contexts for the instance decls
-- required for the corresponding equations.
solveDerivEqns modname inst_decl_infos_in eqns
- `thenTc` \ new_inst_infos ->
+ `thenTc` \ new_inst_infos ->
-- Now augment the InstInfos, adding in the rather boring
-- actual-code-to-do-the-methods binds. We may also need to
-- "con2tag" and/or "tag2con" functions. We do these
-- separately.
- gen_taggery_Names eqns `thenTc` \ nm_alist_etc ->
+ gen_taggery_Names eqns `thenTc` \ nm_alist_etc ->
let
nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ]
deriver_name_funs = (deriv_val_gnf, rn_tc_gnf)
assoc_maybe [] _ = Nothing
- assoc_maybe ((v,xxx) : vs) key
- = if v `eqProtoName` key then Just xxx else assoc_maybe vs key
+ 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_name_funs nm_alist_etc `thenTc` \ extra_binds ->
extra_binds,
ddump_deriving really_new_inst_infos extra_binds)
where
- ddump_deriving :: [InstInfo] -> RenamedBinds -> (PprStyle -> Pretty)
+ ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
ddump_deriving inst_infos extra_binds sty
- = ppAboves ((map (pp_1 sty) inst_infos) ++ [ppr sty extra_binds])
+ = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
where
- pp_1 sty (InstInfo clas tv_tmpls ty inst_decl_theta _ _ _ mbinds _ _ _ _)
- = ppAbove (ppr sty (mkSigmaTy tv_tmpls inst_decl_theta
- (UniDict clas ty)))
+ pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
+ = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
(ppr sty mbinds)
\end{code}
all those.
\begin{code}
-makeDerivEqns :: TCE -> TcM [DerivEqn]
+makeDerivEqns :: TcM s [DerivEqn]
-makeDerivEqns tce
- = let
- think_about_deriving = need_deriving (rngTCE tce)
+makeDerivEqns
+ = tcGetEnv `thenNF_Tc` \ env ->
+ let
+ tycons = eltsUFM (getEnv_TyCons env)
+ think_about_deriving = need_deriving tycons
in
mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
-
- let
- (derive_these, _) = removeDups cmp think_about_deriving
+ let
+ (derive_these, _) = removeDups cmp_deriv think_about_deriving
+ eqns = map mk_eqn derive_these
in
-
- listNF_Tc (map mk_eqn derive_these) `thenNF_Tc` \ eqns ->
-
returnTc eqns
where
------------------------------------------------------------------
[] -> acc
cs -> [ (clas,tycon) | clas <- cs ] ++ acc
)
- [] -- init accumulator
+ []
tycons_to_consider
------------------------------------------------------------------
- chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM ()
-
+ chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
chk_out whole_deriving_list this_one@(clas, tycon)
- = -- Are the relevant superclasses catered for?
- -- E.g., for "... deriving Ord", is there an
- -- instance of "Eq"?
- let
- (_, super_classes, _) = getClassSig clas
+ = let
clas_key = getClassKey clas
in
-- Are things OK for deriving Ix (if appropriate)?
checkTc (clas_key == ixClassKey
- && not (isEnumerationTyCon tycon
- || maybeToBool (maybeSingleConstructorTyCon tycon)))
+ && not (isEnumerationTyCon tycon
+ || maybeToBool (maybeTyConSingleCon tycon)))
(derivingIxErr tycon)
------------------------------------------------------------------
- cmp :: (Class, TyCon) -> (Class, TyCon) -> TAG_
-
- cmp (c1, t1) (c2, t2)
- = case cmpClass c1 c2 of
- EQ_ -> cmpTyCon t1 t2
- other -> other
+ cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
+ cmp_deriv (c1, t1) (c2, t2)
+ = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
------------------------------------------------------------------
- mk_eqn :: (Class, TyCon) -> NF_TcM DerivEqn
- -- we swizzle the tyvars, data cons, etc., out of the tycon,
+ mk_eqn :: (Class, TyCon) -> DerivEqn
+ -- we swizzle the tyvars and datacons out of the tycon
-- to make the rest of the equation
mk_eqn (clas, tycon)
- = let
- tyvar_tmpls = getTyConTyVarTemplates tycon
- data_cons = getTyConDataCons tycon
- in
- copyTyVars tyvar_tmpls `thenNF_Tc` \ (_, tyvars, tyvar_tys) ->
-
- let
- constraints = concat [mk_constraints tyvar_tys con | con <- data_cons]
- in
- returnNF_Tc (clas, tycon, tyvars, constraints)
+ = (clas, tycon, tyvars, constraints)
where
- mk_constraints tyvar_tys data_con
+ tyvars = getTyConTyVars tycon -- ToDo: Do we need new tyvars ???
+ tyvar_tys = map mkTyVarTy tyvars
+ data_cons = getTyConDataCons tycon
+ constraints = concat (map mk_constraints data_cons)
+
+ mk_constraints data_con
= [ (clas, instantiateTy inst_env arg_ty)
| arg_ty <- arg_tys,
not (isPrimType arg_ty) -- No constraints for primitive types
]
where
- (con_tyvar_tmpls, _, arg_tys, _) = getDataConSig data_con
- inst_env = con_tyvar_tmpls `zipEqual` tyvar_tys
- -- Type vars in data contructor should be same in number
- -- as in the type contsructor!
+ (con_tyvars, _, arg_tys, _) = getDataConSig data_con
+ inst_env = con_tyvars `zipEqual` tyvar_tys
+ -- same number of tyvars in data constr and type constr!
\end{code}
%************************************************************************
%* *
%************************************************************************
-A ``solution'' (to one of the equations) is a list of (k,UniTyVar tv)
+A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
terms, which is the final correct RHS for the corresponding original
equation.
\begin{itemize}
\begin{code}
solveDerivEqns :: FAST_STRING
-> Bag InstInfo
- -> [DerivEqn]
- -> TcM [InstInfo] -- Solns in same order as eqns.
+ -> [DerivEqn]
+ -> TcM s [InstInfo] -- Solns in same order as eqns.
-- This bunch is Absolutely minimal...
solveDerivEqns modname inst_decl_infos_in orig_eqns
-- compares it with the current one; finishes if they are the
-- same, otherwise recurses with the new solutions.
- iterateDeriv :: [DerivSoln] ->TcM [InstInfo]
+ iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
iterateDeriv current_solns
- = -- Extend the inst info from the explicit instance decls
+ = -- Extend the inst info from the explicit instance decls
-- with the current set of solutions, giving a
add_solns modname inst_decl_infos_in orig_eqns current_solns
-- inst_mapper reflecting the previous solution
let
mk_deriv_origin clas ty
- = DerivingOrigin inst_mapper clas is_fun_type tycon locn
+ = DerivingOrigin inst_mapper clas tycon
where
- is_fun_type = isFunType ty
- (tycon,_,_) = getUniDataTyCon ty
- locn = if is_fun_type then mkUnknownSrcLoc{-sigh-} else getSrcLoc tycon
+ (tycon,_) = getAppTyCon ty
in
listTc [ tcSimplifyThetas mk_deriv_origin rhs
| (_, _, _, rhs) <- orig_eqns
-- Canonicalise the solutions, so they compare nicely
let canonicalised_next_solns
- = [ sortLt less_than next_soln | next_soln <- next_solns ] in
+ = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
- if current_solns == canonicalised_next_solns then
- returnTc new_inst_infos
- else
- iterateDeriv canonicalised_next_solns
+ if current_solns `eq_solns` canonicalised_next_solns then
+ returnTc new_inst_infos
+ else
+ iterateDeriv canonicalised_next_solns
where
------------------------------------------------------------------
- less_than :: (Class, TauType) -> (Class, TauType) -> Bool
-
- less_than (clas1, UniTyVar tv1) (clas2, UniTyVar tv2)
- = tv1 < tv2 || (tv1 == tv2 && clas1 < clas2)
+ lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False }
+ eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
+ cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
+ cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
+ = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
#ifdef DEBUG
- less_than other_1 other_2
- = pprPanic "tcDeriv:less_than:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
+ cmp_rhs other_1 other_2
+ = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
#endif
+
\end{code}
\begin{code}
add_solns :: FAST_STRING
-> Bag InstInfo -- The global, non-derived ones
-> [DerivEqn] -> [DerivSoln]
- -> TcM ([InstInfo], -- The new, derived ones
- InstanceMapper)
+ -> TcM s ([InstInfo], -- The new, derived ones
+ InstanceMapper)
-- the eqns and solns move "in lockstep"; we have the eqns
-- because we need the LHS info for addClassInstance.
add_solns modname inst_infos_in eqns solns
- = listTc (zipWith mk_deriv_inst_info eqns solns) `thenTc` \ new_inst_infos ->
-
- buildInstanceEnvs (inst_infos_in `unionBags`
- listToBag new_inst_infos) `thenTc` \ inst_mapper ->
-
+ = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
returnTc (new_inst_infos, inst_mapper)
where
- mk_deriv_inst_info (clas, tycon, tyvars, _) theta
- -- The complication here is rather boring: InstInfos need TyVarTemplates,
- -- and we have only TyVars in our hand.
- = let
- tyvar_tmpls = mkTemplateTyVars tyvars
- tv_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls
-
- env = tyvars `zipEqual` tv_tmpl_tys
-
- tycon_tmpl_ty = applyTyCon tycon tv_tmpl_tys
- theta_tmpl = [(clas, mapOverTyVars to_tmpl ty) | (clas,ty) <- theta]
+ new_inst_infos = zipWithEqual mk_deriv_inst_info eqns solns
- to_tmpl = assoc "mk_deriv_inst_info" env
+ all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
- (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
- in
- returnTc (
- InstInfo clas tyvar_tmpls tycon_tmpl_ty
- theta_tmpl
- theta_tmpl -- Blarg. This is the dfun_theta slot,
+ mk_deriv_inst_info (clas, tycon, tyvars, _) theta
+ = InstInfo clas tyvars (applyTyCon tycon (map mkTyVarTy 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
+ -- gen_eqns sets it to its final value
-- (incl super class dicts) before we
-- finally return it.
-#ifndef 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")
- )
+#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
- )
where
bottom = panic "add_soln"
#endif
gen_inst_info :: FAST_STRING -- Module name
-> [RenamedFixityDecl] -- all known fixities;
-- may be needed for Text
- -> GlobalNameFuns -- lookup stuff for names we may use
+ -> GlobalNameMappers -- lookup stuff for names we may use
-> InstInfo -- the main stuff to work on
- -> TcM InstInfo -- the gen'd (filled-in) "instance decl"
+ -> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
gen_inst_info modname fixities deriver_name_funs
- info@(InstInfo clas tyvar_tmpls ty inst_decl_theta _ _ _ _ _ _ locn _)
- =
+ info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
+ =
-- Generate the various instance-related Ids
mkInstanceRelatedIds
- (panic "add_solns:E")
- -- These two are only needed if there are pragmas to typecheck;
- -- but there ain't since we are generating the code right here.
- True {-yes, from_here-}
- modname
+ True {-from_here-} modname
NoInstancePragmas
- mkGeneratedSrcLoc
- clas
- tyvar_tmpls ty
+ clas tyvars ty
inst_decl_theta
[{-no user pragmas-}]
`thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
- -- Generate the bindings for the new instance declaration,
+ -- Generate the bindings for the new instance declaration,
-- rename it, and check for errors
- getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
let
- (tycon,_,_) = getUniDataTyCon ty
-
- omit_readsPrec = sw_chkr OmitDerivedRead
+ (tycon,_,_) = getAppDataTyCon ty
proto_mbinds
- = if clas_key == textClassKey then gen_Text_binds fixities omit_readsPrec tycon
- else if clas_key == eqClassKey then gen_Eq_binds tycon
- else if clas_key == ordClassKey then gen_Ord_binds tycon
- else if clas_key == enumClassKey then gen_Enum_binds tycon
- else if clas_key == ixClassKey then gen_Ix_binds tycon
- else if clas_key == binaryClassKey then gen_Binary_binds tycon
- else panic "gen_inst_info:bad derived class"
+ | 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"
in
rn4MtoTcM deriver_name_funs (
- rnMethodBinds4 clas_Name proto_mbinds
+ rnMethodBinds clas_Name proto_mbinds
) `thenNF_Tc` \ (mbinds, errs) ->
if not (isEmptyBag errs) then
- pprPanic "gen_inst_info:renamer errs!\n" (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug 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) $
+ --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
-- All done
- let
+ let
from_here = isLocallyDefined tycon -- If so, then from here
in
- returnTc (InstInfo clas tyvar_tmpls ty
- inst_decl_theta dfun_theta dfun_id const_meth_ids
- -- and here comes the main point...
+ returnTc (InstInfo clas tyvars ty inst_decl_theta
+ dfun_theta dfun_id const_meth_ids
(if from_here then mbinds else EmptyMonoBinds)
from_here modname locn [])
where
clas_key = getClassKey clas
clas_Name
= let (mod, nm) = getOrigName clas in
- PreludeClass clas_key (mkPreludeCoreName mod nm)
+ ClassName clas_key (mkPreludeCoreName mod nm) []
\end{code}
%************************************************************************
maxtag_Foo :: Int -- ditto (NB: not unboxed)
\begin{code}
-gen_tag_n_con_binds :: GlobalNameFuns
+gen_tag_n_con_binds :: GlobalNameMappers
-> [(ProtoName, Name, TyCon, TagThingWanted)]
- -> TcM RenamedBinds
+ -> TcM s RenamedHsBinds
gen_tag_n_con_binds deriver_name_funs nm_alist_etc
= let
in
rn4MtoTcM deriver_name_funs (
- rnTopBinds4 (SingleBind (RecBind proto_mbinds))
+ rnTopBinds (SingleBind (RecBind proto_mbinds))
) `thenNF_Tc` \ (binds, errs) ->
if not (isEmptyBag errs) then
If we have a @tag2con@ function, we also generate a @maxtag@ constant.
\begin{code}
-data TagThingWanted
- = GenCon2Tag | GenTag2Con | GenMaxTag
-
gen_taggery_Names :: [DerivEqn]
- -> TcM [(ProtoName, Name, -- for an assoc list
- TyCon, -- related tycon
- TagThingWanted)]
+ -> TcM s [(ProtoName, Name, -- for an assoc list
+ TyCon, -- related tycon
+ TagThingWanted)]
gen_taggery_Names eqns
- = let all_tycons = [ tc | (_, tc, _, _) <- eqns ]
- (tycons_of_interest, _) = removeDups cmpTyCon all_tycons
+ = 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
where
do_con2tag acc_Names tycon
= if (we_are_deriving eqClassKey tycon
- && any isNullaryDataCon (getTyConDataCons tycon))
+ && any ( (== 0).getDataConArity ) (getTyConDataCons tycon))
|| (we_are_deriving ordClassKey tycon
- && not (maybeToBool (maybeSingleConstructorTyCon tycon)))
+ && not (maybeToBool (maybeTyConSingleCon tycon)))
|| (we_are_deriving enumClassKey tycon)
|| (we_are_deriving ixClassKey tycon)
then
- getUniqueTc `thenNF_Tc` ( \ u ->
- returnTc ((con2tag_PN tycon, OtherTopId u (con2tag_FN tycon), tycon, GenCon2Tag)
+ tcGetUnique `thenNF_Tc` ( \ u ->
+ returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag)
: acc_Names) )
else
returnTc acc_Names
= if (we_are_deriving enumClassKey tycon)
|| (we_are_deriving ixClassKey tycon)
then
- getUniqueTc `thenNF_Tc` \ u1 ->
- getUniqueTc `thenNF_Tc` \ u2 ->
- returnTc ( (tag2con_PN tycon, OtherTopId u1 (tag2con_FN tycon), tycon, GenTag2Con)
- : (maxtag_PN tycon, OtherTopId u2 (maxtag_FN tycon), tycon, GenMaxTag)
+ 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)
: acc_Names)
else
returnTc acc_Names
= is_in_eqns clas_key tycon eqns
where
is_in_eqns clas_key tycon [] = False
- is_in_eqns clas_key tycon ((c,t,_,_):eqns) -- ToDo: InstInfo
+ is_in_eqns clas_key tycon ((c,t,_,_):eqns)
= (clas_key == getClassKey c && tycon == t)
|| is_in_eqns clas_key tycon eqns
-con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> ProtoName
-con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> FullName
-
-con2tag_PN tycon
- = let (mod, nm) = getOrigName tycon
- con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- Imp mod con2tag [mod] con2tag
-
-con2tag_FN tycon
- = let (mod, nm) = getOrigName tycon
- con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc
-
-tag2con_PN tycon
- = let (mod, nm) = getOrigName tycon
- tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- Imp mod tag2con [mod] tag2con
-
-tag2con_FN tycon
- = let (mod, nm) = getOrigName tycon
- tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc
-
-maxtag_PN tycon
- = let (mod, nm) = getOrigName tycon
- maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- Imp mod maxtag [mod] maxtag
+\end{code}
-maxtag_FN tycon
- = let (mod, nm) = getOrigName tycon
- maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc
+\begin{code}
+derivingEnumErr :: TyCon -> TcError
+derivingEnumErr tycon
+ = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
+ ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
+
+derivingIxErr :: TyCon -> TcError
+derivingIxErr tycon
+ = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
+ ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
\end{code}
--- /dev/null
+\begin{code}
+#include "HsVersions.h"
+
+module TcEnv(
+ TcEnv,
+
+ initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
+
+ tcExtendKindEnv, tcExtendTyVarEnv, tcExtendTyConEnv, tcExtendClassEnv,
+ tcLookupTyVar, tcLookupTyCon, tcLookupClass, tcLookupClassByKey,
+
+ tcExtendGlobalValEnv, tcExtendLocalValEnv,
+ tcLookupLocalValue, tcLookupLocalValueOK,
+ tcLookupGlobalValue, tcLookupGlobalValueByKey,
+
+ tcTyVarScope, newMonoIds, newLocalIds,
+ tcGetGlobalTyVars
+ ) where
+
+
+import Ubiq
+import TcMLoop -- for paranoia checking
+
+import Id ( Id(..), GenId, idType, mkUserLocal )
+import TcHsSyn ( TcIdBndr(..) )
+import TcKind ( TcKind, newKindVars, tcKindToKind, kindToTcKind )
+import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), newTyVarTys, zonkTcTyVars )
+import TyVar ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet )
+import Type ( tyVarsOfTypes )
+import TyCon ( TyCon, getTyConKind )
+import Class ( Class(..), GenClass, getClassSig )
+
+import TcMonad
+
+import Name ( Name(..), getNameShortName )
+import PprStyle
+import Pretty
+import Unique ( Unique )
+import UniqFM
+import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic )
+\end{code}
+
+Data type declarations
+~~~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+data TcEnv s = TcEnv
+ (TyVarEnv s)
+ (ValueEnv Id) -- Globals
+ (ValueEnv (TcIdBndr s)) -- Locals
+ (MutableVar s (TcTyVarSet s)) -- Free type variables of locals
+ -- ...why mutable? see notes with tcGetGlobalTyVars
+ (KindEnv s) -- Gives TcKinds of TyCons and Classes
+ TyConEnv
+ ClassEnv
+
+type TyVarEnv s = UniqFM (TcKind s, TyVar)
+type TyConEnv = UniqFM TyCon
+type KindEnv s = UniqFM (TcKind s)
+type ClassEnv = UniqFM Class
+type ValueEnv id = UniqFM id
+
+initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s
+initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM mut emptyUFM emptyUFM emptyUFM
+
+getEnv_LocalIds (TcEnv _ _ ls _ _ _ _) = ls
+getEnv_TyCons (TcEnv _ _ _ _ _ ts _) = ts
+getEnv_Classes (TcEnv _ _ _ _ _ _ cs) = cs
+\end{code}
+
+Making new TcTyVars, with knot tying!
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcTyVarScope :: [Name] -- Names of some type variables
+ -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
+ -> TcM s a -- Result
+
+tcTyVarScope tyvar_names thing_inside
+ = newKindVars (length tyvar_names) `thenNF_Tc` \ tyvar_kinds ->
+
+ fixTc (\ ~(tyvars, _) ->
+ -- Ok to look at kinds, but not tyvars!
+ tcExtendTyVarEnv tyvar_names (tyvar_kinds `zipLazy` tyvars) (
+
+ -- Do the thing inside
+ thing_inside tyvars `thenTc` \ result ->
+
+ -- Get the tyvar's Kinds from their TcKinds
+ mapNF_Tc tcKindToKind tyvar_kinds `thenNF_Tc` \ tyvar_kinds' ->
+
+ -- Construct the real TyVars
+ let
+ tyvars = zipWithEqual mk_tyvar tyvar_names tyvar_kinds'
+ mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
+ in
+ returnTc (tyvars, result)
+ )) `thenTc` \ (_,result) ->
+ returnTc result
+\end{code}
+
+
+The Kind, TyVar, Class and TyCon envs
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Extending the environments
+
+\begin{code}
+tcExtendKindEnv :: [Name] -> [TcKind s] -> TcM s r -> TcM s r
+tcExtendKindEnv names kinds scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ let
+ ke' = addListToUFM ke (names `zip` kinds)
+ in
+ tcSetEnv (TcEnv tve gve lve gtvs ke' tce ce) scope
+
+tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
+tcExtendTyVarEnv tyvar_names kinds_w_tyvars scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ let
+ tve' = addListToUFM tve (tyvar_names `zip` kinds_w_tyvars)
+ in
+ tcSetEnv (TcEnv tve' gve lve gtvs ke tce ce) scope
+
+tcExtendTyConEnv tycons scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ let
+ tce' = addListToUFM_Directly tce [(getItsUnique tycon, tycon) | tycon <- tycons]
+ in
+ tcSetEnv (TcEnv tve gve lve gtvs ke tce' ce) scope
+
+tcExtendClassEnv classes scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ let
+ ce' = addListToUFM_Directly ce [(getItsUnique clas, clas) | clas <- classes]
+ in
+ tcSetEnv (TcEnv tve gve lve gtvs ke tce ce') scope
+\end{code}
+
+
+Looking up in the environments
+
+\begin{code}
+tcLookupTyVar name
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ returnNF_Tc (lookupWithDefaultUFM tve (panic "tcLookupTyVar") name)
+
+
+tcLookupTyCon (WiredInTyCon tc) -- wired in tycons
+ = returnNF_Tc (kindToTcKind (getTyConKind tc), tc)
+
+tcLookupTyCon name
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ let
+ tycon = lookupWithDefaultUFM tce (panic "tcLookupTyCon") name
+ kind = lookupWithDefaultUFM ke (kindToTcKind (getTyConKind tycon)) name
+ -- The KE will bind tycon in the current mutually-recursive set.
+ -- If the KE doesn't, then the tycon is already defined, and we
+ -- can safely grab the kind from the TyCon itself
+ in
+ returnNF_Tc (kind,tycon)
+
+
+tcLookupClass name
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ let
+ clas = lookupWithDefaultUFM ce (panic "tcLookupClass") name
+ (tyvar, _, _) = getClassSig clas
+ kind = lookupWithDefaultUFM ke (kindToTcKind (getTyVarKind tyvar)) name
+ in
+ returnNF_Tc (kind,clas)
+
+tcLookupClassByKey uniq
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ let
+ clas = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq
+ in
+ returnNF_Tc (clas)
+\end{code}
+
+
+
+Extending and consulting the value environment
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcExtendGlobalValEnv ids scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ let
+ gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids]
+ in
+ tcSetEnv (TcEnv tve gve' lve gtvs ke tce ce) scope
+
+tcExtendLocalValEnv names ids scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
+ let
+ lve' = addListToUFM lve (names `zip` ids)
+ extra_global_tyvars = tyVarsOfTypes (map idType ids)
+ new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tyvars
+ in
+ tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
+
+ tcSetEnv (TcEnv tve gve lve' gtvs' ke tce ce) scope
+\end{code}
+
+@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
+To improve subsequent calls to the same function it writes the zonked set back into
+the environment.
+
+\begin{code}
+tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
+tcGetGlobalTyVars
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
+ zonkTcTyVars global_tvs `thenNF_Tc` \ global_tvs' ->
+ tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
+ returnNF_Tc global_tvs'
+\end{code}
+
+\begin{code}
+tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
+tcLookupLocalValue name
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ returnNF_Tc (lookupUFM lve name)
+
+tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
+tcLookupLocalValueOK err name
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
+
+
+tcLookupGlobalValue :: Name -> NF_TcM s Id
+
+tcLookupGlobalValue (WiredInVal id) -- wired in ids
+ = returnNF_Tc id
+
+tcLookupGlobalValue name
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ returnNF_Tc (lookupWithDefaultUFM gve def name)
+ where
+#ifdef DEBUG
+ def = panic ("tcLookupGlobalValue:" ++ ppShow 1000 (ppr PprDebug name))
+#else
+ def = panic "tcLookupGlobalValue"
+#endif
+
+
+tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
+tcLookupGlobalValueByKey uniq
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve gve lve gtvs ke tce ce) ->
+ returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
+ where
+#ifdef DEBUG
+ def = panic ("tcLookupGlobalValueByKey:" ++ ppShow 1000 (ppr PprDebug uniq))
+#else
+ def = panic "tcLookupGlobalValueByKey"
+#endif
+
+\end{code}
+
+
+Constructing new Ids
+~~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
+newMonoIds names kind m
+ = newTyVarTys no_of_names kind `thenNF_Tc` \ tys ->
+ tcGetUniques no_of_names `thenNF_Tc` \ uniqs ->
+ let
+ new_ids = zipWith3Equal mk_id names uniqs tys
+ mk_id name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
+ (getSrcLoc name)
+ in
+ tcExtendLocalValEnv names new_ids (m new_ids)
+ where
+ no_of_names = length names
+
+newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdBndr s]
+newLocalIds names tys
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
+ let
+ new_ids = zipWith3Equal mk_id names uniqs tys
+ mk_id name uniq ty = mkUserLocal name uniq ty loc
+ in
+ returnNF_Tc new_ids
+\end{code}
+
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcExpr where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsExpr(Expr)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcExpr :: E -> Expr Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Expr Id TypecheckedPat, LIE, UniType)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[TcExpr]{TcExpr}
+\section[TcExpr]{Typecheck an expression}
\begin{code}
#include "HsVersions.h"
-module TcExpr (
- tcExpr
-#ifdef DPH
- , tcExprs
-#endif
- ) where
-
-import TcMonad -- typechecking monad machinery
-import TcMonadFns ( newPolyTyVarTy, newOpenTyVarTy,
- newDict, newMethod, newOverloadedLit,
- applyTcSubstAndCollectTyVars,
- mkIdsWithPolyTyVarTys
- )
-import AbsSyn -- the stuff being typechecked
-
-
-import AbsPrel ( intPrimTy, charPrimTy, doublePrimTy,
- floatPrimTy, addrPrimTy, addrTy,
- boolTy, charTy, stringTy, mkFunTy, mkListTy,
- mkTupleTy, mkPrimIoTy
-#ifdef DPH
- ,mkProcessorTy, mkPodTy,toPodId,
- processorClass,pidClass
-#endif {- Data Parallel Haskell -}
- )
-import AbsUniType
-import E
-import CE ( lookupCE )
-
-import Errors
-import GenSpecEtc ( checkSigTyVars )
-import Id ( mkInstId, getIdUniType, Id )
-import Inst
-import LIE ( nullLIE, unitLIE, plusLIE, unMkLIE, mkLIE, LIE )
-import ListSetOps ( unionLists )
-import Maybes ( Maybe(..) )
-import TVE ( nullTVE, TVE(..) )
-import Spec ( specId, specTy )
-import TcBinds ( tcLocalBindsAndThen )
+module TcExpr ( tcExpr ) where
+
+import Ubiq
+
+import HsSyn ( HsExpr(..), Qual(..), Stmt(..),
+ HsBinds(..), Bind(..), MonoBinds(..),
+ ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
+ Match, Fake, InPat, OutPat, PolyType,
+ irrefutablePat, collectPatBinders )
+import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..), RenamedStmt(..) )
+import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..), TcIdOcc(..) )
+
+import TcMonad
+import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
+ LIE(..), emptyLIE, plusLIE, newOverloadedLit,
+ newMethod, newMethodWithGivenTy, newDicts )
+import TcBinds ( tcBindsAndThen )
+import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
+ tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars )
import TcMatches ( tcMatchesCase, tcMatch )
-import TcPolyType ( tcPolyType )
-import TcQuals ( tcQuals )
+import TcMonoType ( tcPolyType )
+import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
-#ifdef DPH
-import TcParQuals
-#endif {- Data Parallel Haskell -}
+import TcType ( TcType(..), TcMaybe(..), tcReadTyVar,
+ tcInstType, tcInstTcType,
+ tcInstTyVar, newTyVarTy, zonkTcTyVars )
+
+import Class ( Class(..), getClassSig )
+import Id ( Id(..), GenId, idType )
+import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
+import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals, specTy )
+import PrelInfo ( intPrimTy, charPrimTy, doublePrimTy,
+ floatPrimTy, addrPrimTy, addrTy,
+ boolTy, charTy, stringTy, mkListTy,
+ mkTupleTy, mkPrimIoTy )
+import Type ( mkFunTy, mkAppTy, mkTyVarTy,
+ getTyVar_maybe, getFunTy_maybe,
+ splitForAllTy, splitRhoTy, splitSigmaTy,
+ isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe )
+import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, tyVarListToSet )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
-import UniqFM ( emptyUFM ) -- profiling, pragmas only
-import Unique -- *Key stuff
+import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
+ enumFromClassOpKey, enumFromThenClassOpKey,
+ enumFromToClassOpKey, enumFromThenToClassOpKey,
+ monadClassKey, monadZeroClassKey )
+
+import Name ( Name ) -- Instance
+import PprType ( GenType, GenTyVar ) -- Instances
+import Maybes ( maybeToBool )
+import Pretty
import Util
+\end{code}
-tcExpr :: E -> RenamedExpr -> TcM (TypecheckedExpr, LIE, UniType)
+\begin{code}
+tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcExpr e (Var name)
- = specId (lookupE_Value e name) `thenNF_Tc` \ stuff@(expr, lie, ty) ->
+tcExpr (HsVar name)
+ = tcId name `thenTc` \ (expr', lie, res_ty) ->
- -- Check that there's no lurking rank-2 polymorphism
- -- isTauTy is over-paranoid, because we don't expect
- -- any submerged polymorphism other than rank-2 polymorphism
+ -- Check that the result type doesn't have any nested for-alls.
+ -- For example, a "build" on its own is no good; it must be
+ -- applied to something.
+ checkTc (isTauTy res_ty)
+ (lurkingRank2Err name res_ty) `thenTc_`
- getSrcLocTc `thenNF_Tc` \ loc ->
- checkTc (not (isTauTy ty)) (lurkingRank2Err name ty loc) `thenTc_`
-
- returnTc stuff
+ returnTc (expr', lie, res_ty)
\end{code}
%************************************************************************
Overloaded literals.
\begin{code}
-tcExpr e (Lit lit@(IntLit i))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- newPolyTyVarTy `thenNF_Tc` \ ty ->
- let
- from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
- from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
- in
- newOverloadedLit (LiteralOrigin lit loc)
- (OverloadedIntegral i from_int from_integer)
- ty
- `thenNF_Tc` \ over_lit ->
+tcExpr (HsLit (HsInt i))
+ = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
- returnTc (Var (mkInstId over_lit), unitLIE over_lit, ty)
+ newOverloadedLit (LiteralOrigin (HsInt i))
+ (OverloadedIntegral i)
+ ty `thenNF_Tc` \ (lie, over_lit_id) ->
-tcExpr e (Lit lit@(FracLit f))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- newPolyTyVarTy `thenNF_Tc` \ ty ->
- let
- from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational")
- in
- newOverloadedLit (LiteralOrigin lit loc)
- (OverloadedFractional f from_rational)
- ty
- `thenNF_Tc` \ over_lit ->
+ returnTc (HsVar over_lit_id, lie, ty)
- returnTc (Var (mkInstId over_lit), unitLIE over_lit, ty)
+tcExpr (HsLit (HsFrac f))
+ = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
-tcExpr e (Lit lit@(LitLitLitIn s))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- let
- -- Get the callable class. Rather turgid and a HACK (ToDo).
- ce = getE_CE e
- cCallableClass = lookupCE ce (PreludeClass cCallableClassKey bottom)
- bottom = panic "tcExpr:LitLitLit"
- in
- newPolyTyVarTy `thenNF_Tc` \ ty ->
-
- newDict (LitLitOrigin loc (_UNPK_ s)) cCallableClass ty `thenNF_Tc` \ dict ->
+ newOverloadedLit (LiteralOrigin (HsFrac f))
+ (OverloadedFractional f)
+ ty `thenNF_Tc` \ (lie, over_lit_id) ->
+
+ returnTc (HsVar over_lit_id, lie, ty)
- returnTc (Lit (LitLitLit s ty), mkLIE [dict], ty)
+tcExpr (HsLit lit@(HsLitLit s))
+ = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
+ newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
+ newDicts (LitLitOrigin (_UNPK_ s))
+ [(cCallableClass, ty)] `thenNF_Tc` \ (dicts, _) ->
+ returnTc (HsLitOut lit ty, dicts, ty)
\end{code}
Primitive literals:
\begin{code}
-tcExpr e (Lit (CharPrimLit c))
- = returnTc (Lit (CharPrimLit c), nullLIE, charPrimTy)
+tcExpr (HsLit lit@(HsCharPrim c))
+ = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
-tcExpr e (Lit (StringPrimLit s))
- = returnTc (Lit (StringPrimLit s), nullLIE, addrPrimTy)
+tcExpr (HsLit lit@(HsStringPrim s))
+ = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
-tcExpr e (Lit (IntPrimLit i))
- = returnTc (Lit (IntPrimLit i), nullLIE, intPrimTy)
+tcExpr (HsLit lit@(HsIntPrim i))
+ = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
-tcExpr e (Lit (FloatPrimLit f))
- = returnTc (Lit (FloatPrimLit f), nullLIE, floatPrimTy)
+tcExpr (HsLit lit@(HsFloatPrim f))
+ = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
-tcExpr e (Lit (DoublePrimLit d))
- = returnTc (Lit (DoublePrimLit d), nullLIE, doublePrimTy)
+tcExpr (HsLit lit@(HsDoublePrim d))
+ = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
\end{code}
Unoverloaded literals:
\begin{code}
-tcExpr e (Lit (CharLit c))
- = returnTc (Lit (CharLit c), nullLIE, charTy)
+tcExpr (HsLit lit@(HsChar c))
+ = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
-tcExpr e (Lit (StringLit str))
- = returnTc (Lit (StringLit str), nullLIE, stringTy)
+tcExpr (HsLit lit@(HsString str))
+ = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcExpr e (Lam match)
- = tcMatch e match `thenTc` \ (match',lie,ty) ->
- returnTc (Lam match',lie,ty)
+tcExpr (HsLam match)
+ = tcMatch match `thenTc` \ (match',lie,ty) ->
+ returnTc (HsLam match', lie, ty)
-tcExpr e (App e1 e2) = accum e1 [e2]
- where
- accum (App e1 e2) args = accum e1 (e2:args)
- accum fun args = tcApp (foldl App) e fun args
+tcExpr (HsApp e1 e2) = accum e1 [e2]
+ where
+ accum (HsApp e1 e2) args = accum e1 (e2:args)
+ accum fun args
+ = tcApp fun args `thenTc` \ (fun', args', lie, res_ty) ->
+ returnTc (foldl HsApp fun' args', lie, res_ty)
-- equivalent to (op e1) e2:
-tcExpr e (OpApp e1 op e2)
- = tcApp (\fun [arg1,arg2] -> OpApp arg1 fun arg2) e op [e1,e2]
+tcExpr (OpApp arg1 op arg2)
+ = tcApp op [arg1,arg2] `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
+ returnTc (OpApp arg1' op' arg2', lie, res_ty)
\end{code}
Note that the operators in sections are expected to be binary, and
a type error will occur if they aren't.
\begin{code}
--- equivalent to
--- \ x -> e op x,
+-- Left sections, equivalent to
+-- \ x -> e op x,
-- or
--- \ x -> op e x,
+-- \ x -> op e x,
-- or just
-- op e
-tcExpr e (SectionL expr op)
- = tcApp (\ fun [arg] -> SectionL arg fun) e op [expr]
+tcExpr in_expr@(SectionL arg op)
+ = tcApp op [arg] `thenTc` \ (op', [arg'], lie, res_ty) ->
+
+ -- Check that res_ty is a function type
+ -- Without this check we barf in the desugarer on
+ -- f op = (3 `op`)
+ -- because it tries to desugar to
+ -- f op = \r -> 3 op r
+ -- so (3 `op`) had better be a function!
+ newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
+ newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
+ tcAddErrCtxt (sectionLAppCtxt in_expr) $
+ unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
--- equivalent to \ x -> x op expr, or
+ returnTc (SectionL arg' op', lie, res_ty)
+
+-- Right sections, equivalent to \ x -> x op expr, or
-- \ x -> op x expr
-tcExpr e (SectionR op expr)
- = tcExpr e op `thenTc` \ (op', lie1, op_ty) ->
- tcExpr e expr `thenTc` \ (expr',lie2, expr_ty) ->
- newOpenTyVarTy `thenNF_Tc` \ ty1 ->
- newOpenTyVarTy `thenNF_Tc` \ ty2 ->
- let
- result_ty = mkFunTy ty1 ty2
- in
- unifyTauTy op_ty (mkFunTy ty1 (mkFunTy expr_ty ty2))
- (SectionRAppCtxt op expr) `thenTc_`
+tcExpr in_expr@(SectionR op expr)
+ = tcExpr op `thenTc` \ (op', lie1, op_ty) ->
+ tcExpr expr `thenTc` \ (expr',lie2, expr_ty) ->
+
+ newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
+ newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
+ tcAddErrCtxt (sectionRAppCtxt in_expr) $
+ unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2) `thenTc_`
- returnTc (SectionR op' expr', plusLIE lie1 lie2, result_ty)
+ returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
\end{code}
The interesting thing about @ccall@ is that it is just a template
later use.
\begin{code}
-tcExpr e (CCall lbl args may_gc is_asm ignored_fake_result_ty)
- = getSrcLocTc `thenNF_Tc` \ src_loc ->
- let
- -- Get the callable and returnable classes. Rather turgid (ToDo).
- ce = getE_CE e
- cCallableClass = lookupCE ce (PreludeClass cCallableClassKey bottom)
- cReturnableClass = lookupCE ce (PreludeClass cReturnableClassKey bottom)
- bottom = panic "tcExpr:CCall"
+tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
+ = -- Get the callable and returnable classes.
+ tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
+ tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
- new_arg_dict (arg, arg_ty) = newDict (CCallOrigin src_loc (_UNPK_ lbl) (Just arg))
- cCallableClass arg_ty
+ let
+ new_arg_dict (arg, arg_ty)
+ = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
+ [(cCallableClass, arg_ty)] `thenNF_Tc` \ (arg_dicts, _) ->
+ returnNF_Tc arg_dicts -- Actually a singleton bag
- result_origin = CCallOrigin src_loc (_UNPK_ lbl) Nothing {- Not an arg -}
+ result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
in
-
+
-- Arguments
- tcExprs e args `thenTc` \ (args', args_lie, arg_tys) ->
+ tcExprs args `thenTc` \ (args', args_lie, arg_tys) ->
-- The argument types can be unboxed or boxed; the result
- -- type must, however, be boxed since it's an argument to the PrimIO
+ -- type must, however, be boxed since it's an argument to the PrimIO
-- type constructor.
- newPolyTyVarTy `thenNF_Tc` \ result_ty ->
+ newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
-- Construct the extra insts, which encode the
-- constraints on the argument and result types.
- mapNF_Tc new_arg_dict (args `zip` arg_tys) `thenNF_Tc` \ arg_dicts ->
- newDict result_origin cReturnableClass result_ty `thenNF_Tc` \ res_dict ->
-
- returnTc (CCall lbl args' may_gc is_asm result_ty,
- args_lie `plusLIE` mkLIE (res_dict : arg_dicts),
+ mapNF_Tc new_arg_dict (args `zip` arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
+ newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
+
+ returnTc (CCall lbl args' may_gc is_asm result_ty,
+ foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
mkPrimIoTy result_ty)
\end{code}
\begin{code}
-tcExpr e (SCC label expr)
- = tcExpr e expr `thenTc` \ (expr', lie, expr_ty) ->
+tcExpr (HsSCC label expr)
+ = tcExpr expr `thenTc` \ (expr', lie, expr_ty) ->
-- No unification. Give SCC the type of expr
- returnTc (SCC label expr', lie, expr_ty)
+ returnTc (HsSCC label expr', lie, expr_ty)
+
+tcExpr (HsLet binds expr)
+ = tcBindsAndThen
+ HsLet -- The combiner
+ binds -- Bindings to check
+ (tcExpr expr) -- Typechecker for the expression
-tcExpr e (Let binds expr)
- = tcLocalBindsAndThen e
- Let -- The combiner
- binds -- Bindings to check
- (\ e -> tcExpr e expr) -- Typechecker for the expression
+tcExpr in_expr@(HsCase expr matches src_loc)
+ = tcAddSrcLoc src_loc $
+ tcExpr expr `thenTc` \ (expr',lie1,expr_ty) ->
+ newTyVarTy mkTypeKind `thenNF_Tc` \ result_ty ->
-tcExpr e (Case expr matches)
- = tcExpr e expr `thenTc` \ (expr',lie1,expr_ty) ->
- tcMatchesCase e matches `thenTc` \ (matches',lie2,match_ty) ->
- newOpenTyVarTy `thenNF_Tc` \ result_ty ->
+ tcAddErrCtxt (caseCtxt in_expr) $
+ tcMatchesCase (mkFunTy expr_ty result_ty) matches
+ `thenTc` \ (matches',lie2) ->
- unifyTauTy (mkFunTy expr_ty result_ty) match_ty
- (CaseCtxt expr matches) `thenTc_`
+ returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
- returnTc (Case expr' matches', plusLIE lie1 lie2, result_ty)
+tcExpr (HsIf pred b1 b2 src_loc)
+ = tcAddSrcLoc src_loc $
+ tcExpr pred `thenTc` \ (pred',lie1,predTy) ->
-tcExpr e (If pred b1 b2)
- = tcExpr e pred `thenTc` \ (pred',lie1,predTy) ->
+ tcAddErrCtxt (predCtxt pred) (
+ unifyTauTy predTy boolTy
+ ) `thenTc_`
- unifyTauTy predTy boolTy (PredCtxt pred) `thenTc_`
+ tcExpr b1 `thenTc` \ (b1',lie2,result_ty) ->
+ tcExpr b2 `thenTc` \ (b2',lie3,b2Ty) ->
- tcExpr e b1 `thenTc` \ (b1',lie2,result_ty) ->
- tcExpr e b2 `thenTc` \ (b2',lie3,b2Ty) ->
+ tcAddErrCtxt (branchCtxt b1 b2) $
+ unifyTauTy result_ty b2Ty `thenTc_`
- unifyTauTy result_ty b2Ty (BranchCtxt b1 b2) `thenTc_`
+ returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
- returnTc (If pred' b1' b2', plusLIE lie1 (plusLIE lie2 lie3), result_ty)
+tcExpr (ListComp expr quals)
+ = tcListComp expr quals `thenTc` \ ((expr',quals'), lie, ty) ->
+ returnTc (ListComp expr' quals', lie, ty)
+\end{code}
-tcExpr e (ListComp expr quals)
- = mkIdsWithPolyTyVarTys binders `thenNF_Tc` \ lve ->
- -- Binders of a list comprehension must be boxed.
+\begin{code}
+tcExpr (HsDo stmts src_loc)
+ = -- get the Monad and MonadZero classes
+ -- create type consisting of a fresh monad tyvar
+ tcAddSrcLoc src_loc $
+ tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass ->
+ tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass ->
let
- new_e = growE_LVE e lve
+ (tv,_,_) = getClassSig monadClass
in
- tcQuals new_e quals `thenTc` \ (quals',lie1) ->
- tcExpr new_e expr `thenTc` \ (expr', lie2, ty) ->
- returnTc (ListComp expr' quals', plusLIE lie1 lie2, mkListTy ty)
- where
- binders = collectQualBinders quals
+ tcInstTyVar tv `thenNF_Tc` \ m_tyvar ->
+ let
+ m = mkTyVarTy m_tyvar
+ in
+ tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
+
+ -- create dictionaries for monad and possibly monadzero
+ (if monad then
+ newDicts DoOrigin [(monadClass, m)]
+ else
+ returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
+ ) `thenNF_Tc` \ (m_lie, [m_id]) ->
+ (if mzero then
+ 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)
\end{code}
\begin{code}
-tcExpr e (ExplicitList [])
- = newPolyTyVarTy `thenNF_Tc` \ tyvar_ty ->
- returnTc (ExplicitListOut tyvar_ty [], nullLIE, mkListTy tyvar_ty)
+tcExpr (ExplicitList [])
+ = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
+ returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
-tcExpr e (ExplicitList exprs) -- Non-empty list
- = tcExprs e exprs `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
- unifyTauTyList tys (ListCtxt exprs) `thenTc_`
+tcExpr in_expr@(ExplicitList exprs) -- Non-empty list
+ = tcExprs exprs `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
+ tcAddErrCtxt (listCtxt in_expr) $
+ unifyTauTyList tys `thenTc_`
returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
-tcExpr e (ExplicitTuple exprs)
- = tcExprs e exprs `thenTc` \ (exprs', lie, tys) ->
+tcExpr (ExplicitTuple exprs)
+ = tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
-tcExpr e (ArithSeqIn seq@(From expr))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- tcExpr e expr `thenTc` \ (expr', lie, ty) ->
- let
- enum_from_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFrom")
- in
- newMethod (ArithSeqOrigin seq loc)
- enum_from_id [ty] `thenNF_Tc` \ enum_from ->
+tcExpr (RecordCon con rbinds)
+ = panic "tcExpr:RecordCon"
+tcExpr (RecordUpd exp rbinds)
+ = panic "tcExpr:RecordUpd"
- returnTc (ArithSeqOut (Var (mkInstId enum_from)) (From expr'),
- plusLIE (unitLIE enum_from) lie,
- mkListTy ty)
+tcExpr (ArithSeqIn seq@(From expr))
+ = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
-tcExpr e (ArithSeqIn seq@(FromThen expr1 expr2))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- tcExpr e expr1 `thenTc` \ (expr1',lie1,ty1) ->
- tcExpr e expr2 `thenTc` \ (expr2',lie2,ty2) ->
+ tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
+ newMethod (ArithSeqOrigin seq)
+ (RealId sel_id) [ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
- unifyTauTyList [ty1, ty2] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_`
- let
- enum_from_then_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromThen")
- in
- newMethod (ArithSeqOrigin seq loc)
- enum_from_then_id [ty1] `thenNF_Tc` \ enum_from_then ->
+ returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
+ lie1 `plusLIE` lie2,
+ mkListTy ty)
- returnTc (ArithSeqOut (Var (mkInstId enum_from_then))
+tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
+ = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
+ tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
+
+ tcAddErrCtxt (arithSeqCtxt in_expr) $
+ unifyTauTyList [ty1, ty2] `thenTc_`
+
+ tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
+ newMethod (ArithSeqOrigin seq)
+ (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
+
+ returnTc (ArithSeqOut (HsVar enum_from_then_id)
(FromThen expr1' expr2'),
- (unitLIE enum_from_then) `plusLIE` lie1 `plusLIE` lie2,
+ lie1 `plusLIE` lie2 `plusLIE` lie3,
mkListTy ty1)
-tcExpr e (ArithSeqIn seq@(FromTo expr1 expr2))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- tcExpr e expr1 `thenTc` \ (expr1',lie1,ty1) ->
- tcExpr e expr2 `thenTc` \ (expr2',lie2,ty2) ->
+tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
+ = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
+ tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
- unifyTauTyList [ty1,ty2] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_`
- let
- enum_from_to_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromTo")
- in
- newMethod (ArithSeqOrigin seq loc)
- enum_from_to_id [ty1] `thenNF_Tc` \ enum_from_to ->
- returnTc (ArithSeqOut (Var (mkInstId enum_from_to))
- (FromTo expr1' expr2'),
- (unitLIE enum_from_to) `plusLIE` lie1 `plusLIE` lie2,
+ tcAddErrCtxt (arithSeqCtxt in_expr) $
+ unifyTauTyList [ty1,ty2] `thenTc_`
+
+ tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
+ newMethod (ArithSeqOrigin seq)
+ (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
+
+ returnTc (ArithSeqOut (HsVar enum_from_to_id)
+ (FromTo expr1' expr2'),
+ lie1 `plusLIE` lie2 `plusLIE` lie3,
mkListTy ty1)
-tcExpr e (ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- tcExpr e expr1 `thenTc` \ (expr1',lie1,ty1) ->
- tcExpr e expr2 `thenTc` \ (expr2',lie2,ty2) ->
- tcExpr e expr3 `thenTc` \ (expr3',lie3,ty3) ->
+tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
+ = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
+ tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
+ tcExpr expr3 `thenTc` \ (expr3',lie3,ty3) ->
- unifyTauTyList [ty1,ty2,ty3] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_`
- let
- enum_from_then_to_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromThenTo")
- in
- newMethod (ArithSeqOrigin seq loc)
- enum_from_then_to_id [ty1] `thenNF_Tc` \ enum_from_then_to ->
+ tcAddErrCtxt (arithSeqCtxt in_expr) $
+ unifyTauTyList [ty1,ty2,ty3] `thenTc_`
- returnTc (ArithSeqOut (Var (mkInstId enum_from_then_to))
+ tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
+ newMethod (ArithSeqOrigin seq)
+ (RealId sel_id) [ty1] `thenNF_Tc` \ (lie4, eft_id) ->
+
+ returnTc (ArithSeqOut (HsVar eft_id)
(FromThenTo expr1' expr2' expr3'),
- (unitLIE enum_from_then_to) `plusLIE` lie1 `plusLIE` lie2 `plusLIE` lie3,
- mkListTy ty1)
+ lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
+ mkListTy ty1)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcExpr e (ExprWithTySig expr poly_ty)
- = tcExpr e expr `thenTc` \ (texpr, lie, tau_ty) ->
- babyTcMtoTcM (tcPolyType (getE_CE e) (getE_TCE e) nullTVE poly_ty) `thenTc` \ sigma_sig ->
+tcExpr in_expr@(ExprWithTySig expr poly_ty)
+ = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) ->
+ tcPolyType poly_ty `thenTc` \ sigma_sig ->
-- Check the tau-type part
- specTy SignatureOrigin sigma_sig `thenNF_Tc` \ (sig_tyvars, sig_dicts, sig_tau) ->
- unifyTauTy tau_ty sig_tau (ExprSigCtxt expr sig_tau) `thenTc_`
+ tcSetErrCtxt (exprSigCtxt in_expr) $
+ specTy SignatureOrigin sigma_sig `thenNF_Tc` \ (sig_tyvars, sig_dicts, sig_tau, _) ->
+ unifyTauTy tau_ty sig_tau `thenTc_`
-- Check the type variables of the signature
- applyTcSubstAndCollectTyVars (tvOfE e) `thenNF_Tc` \ env_tyvars ->
- checkSigTyVars env_tyvars sig_tyvars sig_tau tau_ty (ExprSigCtxt expr sig_tau)
- `thenTc` \ sig_tyvars' ->
+ checkSigTyVars sig_tyvars sig_tau tau_ty `thenTc` \ sig_tyvars' ->
-- Check overloading constraints
tcSimplifyAndCheck
- False {- Not top level -}
- env_tyvars sig_tyvars'
- sig_dicts (unMkLIE lie)
- (ExprSigCtxt expr sigma_sig) `thenTc_`
+ (tyVarListToSet sig_tyvars')
+ sig_dicts lie `thenTc_`
-- If everything is ok, return the stuff unchanged, except for
-- the effect of any substutions etc. We simply discard the
%************************************************************************
%* *
-\subsection{Data Parallel Expressions (DPH only)}
+\subsection{@tcApp@ typchecks an application}
%* *
%************************************************************************
-Constraints enforced by the Static semantics for ParallelZF
-$exp_1$ = << $exp_2$ | quals >>
+\begin{code}
+tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
+ -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
+ LIE s,
+ TcType s) -- Type of the application
-\begin{enumerate}
-\item The type of the expression $exp_1$ is <<$exp_2$>>
-\item The type of $exp_2$ must be in the class {\tt Processor}
-\end{enumerate}
+tcApp fun args
+ = -- First type-check the function
+ -- In the HsVar case we go straight to tcId to avoid hitting the
+ -- rank-2 check, which we check later here anyway
+ (case fun of
+ HsVar name -> tcId name
+ other -> tcExpr fun
+ ) `thenTc` \ (fun', lie_fun, fun_ty) ->
-\begin{code}
-#ifdef DPH
-tcExpr e (ParallelZF expr quals)
- = let binders = collectParQualBinders quals in
- mkIdsWithPolyTyVarTys binders `thenNF_Tc` (\ lve ->
- let e' = growE_LVE e lve in
- tcParQuals e' quals `thenTc` (\ (quals',lie1) ->
- tcExpr e' expr `thenTc` (\ (expr', lie2,ty) ->
- getSrcLocTc `thenNF_Tc` (\ src_loc ->
- if (isProcessorTy ty) then
- returnTc (ParallelZF expr' quals',
- plusLIE lie1 lie2 ,
- mkPodTy ty)
- else
- failTc (podCompLhsError ty src_loc)
- ))))
-#endif {- Data Parallel Haskell -}
-\end{code}
+ tcApp_help fun 1 fun_ty args `thenTc` \ (args', lie_args, res_ty) ->
-Constraints enforced by the Static semantics for Explicit Pods
-exp = << $exp_1$ ... $exp_n$>> (where $n >= 0$)
+ -- Check that the result type doesn't have any nested for-alls.
+ -- For example, a "build" on its own is no good; it must be applied to something.
+ checkTc (isTauTy res_ty)
+ (lurkingRank2Err fun fun_ty) `thenTc_`
-\begin{enumerate}
-\item The type of the all the expressions in the Pod must be the same.
-\item The type of an expression in a POD must be in class {\tt Processor}
-\end{enumerate}
+ returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
-\begin{code}
-#ifdef DPH
-tcExpr e (ExplicitPodIn exprs)
- = panic "Ignoring explicit PODs for the time being"
-{-
- = tcExprs e exprs `thenTc` (\ (exprs',lie,tys) ->
- newPolyTyVarTy `thenNF_Tc` (\ elt_ty ->
- newDict processorClass elt_ty `thenNF_Tc` (\ procDict ->
- let
- procLie = mkLIEFromDicts procDict
- in
- unifyTauTyList (elt_ty:tys) (PodCtxt exprs) `thenTc_`
-
- returnTc ((App
- (DictApp
- (TyApp (Var toPodId) [elt_ty])
- procDict)
- (ExplicitListOut elt_ty exprs')),
- plusLIE procLie lie,
- mkPodTy elt_ty)
- ))) -}
-#endif {- Data Parallel Haskell -}
-\end{code}
-\begin{code}
-#ifdef DPH
-tcExpr e (ExplicitProcessor exprs expr)
- = tcPidExprs e exprs `thenTc` (\ (exprs',lie1,tys) ->
- tcExpr e expr `thenTc` (\ (expr',lie2,ty) ->
- returnTc (ExplicitProcessor exprs' expr',
- plusLIE lie1 lie2,
- mkProcessorTy tys ty)
- ))
-#endif {- Data Parallel Haskell -}
-\end{code}
+tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error message(s)
+ -> TcType s -- The type of the function
+ -> [RenamedHsExpr] -- Arguments
+ -> TcM s ([TcExpr s], -- Typechecked args
+ LIE s,
+ TcType s) -- Result type of the application
-%************************************************************************
-%* *
-\subsection{@tcExprs@ typechecks a {\em list} of expressions}
-%* *
-%************************************************************************
+tcApp_help orig_fun arg_no fun_ty []
+ = returnTc ([], emptyLIE, fun_ty)
-ToDo: Possibly find a version of a listTc TcM which would pass the
-appropriate functions for the LIE.
+tcApp_help orig_fun arg_no fun_ty (arg:args)
+ | maybeToBool maybe_arrow_ty
+ = -- The function's type is A->B
+ tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
+ tcArg expected_arg_ty arg
+ ) `thenTc` \ (arg', lie_arg) ->
-\begin{code}
-tcExprs :: E -> [RenamedExpr] -> TcM ([TypecheckedExpr],LIE,[TauType])
+ tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) ->
+ returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
-tcExprs e [] = returnTc ([], nullLIE, [])
-tcExprs e (expr:exprs)
- = tcExpr e expr `thenTc` \ (expr', lie1, ty) ->
- tcExprs e exprs `thenTc` \ (exprs', lie2, tys) ->
- returnTc (expr':exprs', plusLIE lie1 lie2, ty:tys)
-\end{code}
+ | maybeToBool maybe_tyvar_ty
+ = -- The function's type is just a type variable
+ tcReadTyVar fun_tyvar `thenNF_Tc` \ maybe_fun_ty ->
+ case maybe_fun_ty of
+ BoundTo new_fun_ty -> -- The tyvar in the corner of the function is bound
+ -- to something ... so carry on ....
+ tcApp_help orig_fun arg_no new_fun_ty (arg:args)
-%************************************************************************
-%* *
-\subsection{@tcApp@ typchecks an application}
-%* *
-%************************************************************************
+ UnBound -> -- Extra args match against an unbound type
+ -- variable as the final result type, so unify the tyvar.
+ newTyVarTy mkTypeKind `thenNF_Tc` \ result_ty ->
+ tcExprs args `thenTc` \ (args', lie_args, arg_tys) ->
-\begin{code}
-tcApp :: (TypecheckedExpr -> [TypecheckedExpr] -> TypecheckedExpr) -- Result builder
- -> E
- -> RenamedExpr
- -> [RenamedExpr]
- -> TcM (TypecheckedExpr, LIE, UniType)
-
-tcApp build_result_expression e orig_fun arg_exprs
- = tcExpr' e orig_fun (length arg_exprs)
- `thenTc` \ (fun', lie_fun, fun_ty) ->
- unify_fun 1 fun' lie_fun arg_exprs fun_ty
- where
- -- Used only in the error message
- maybe_fun_id = case orig_fun of
- Var name -> Just (lookupE_Value e name)
- other -> Nothing
-
- unify_args :: Int -- Current argument number
- -> TypecheckedExpr -- Current rebuilt expression
- -> LIE -- Corresponding LIE
- -> [RenamedExpr] -- Remaining args
- -> [TauType] -- Remaining arg types
- -> TauType -- result type
- -> TcM (TypecheckedExpr, LIE, UniType)
-
- unify_args arg_no fun lie (arg:args) (arg_ty:arg_tys) fun_res_ty
- = tcExpr e arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
-
- -- These applyTcSubstToTy's are just to improve the error message...
- applyTcSubstToTy actual_arg_ty `thenNF_Tc` \ actual_arg_ty' ->
- applyTcSubstToTy arg_ty `thenNF_Tc` \ arg_ty' ->
- let
- err_ctxt = FunAppCtxt orig_fun maybe_fun_id arg arg_ty' actual_arg_ty' arg_no
- in
- matchArgTy e arg_ty' arg' lie_arg actual_arg_ty' err_ctxt
- `thenTc` \ (arg'', lie_arg') ->
-
- unify_args (arg_no+1) (App fun arg'') (lie `plusLIE` lie_arg') args arg_tys fun_res_ty
-
- unify_args arg_no fun lie [] arg_tys fun_res_ty
- = -- We've run out of actual arguments. Check that none of
- -- arg_tys has a for-all at the top. For example, "build" on
- -- its own is no good; it must be applied to something.
- let
- result_ty = glueTyArgs arg_tys fun_res_ty
- in
- getSrcLocTc `thenNF_Tc` \ loc ->
- checkTc (not (isTauTy result_ty))
- (underAppliedTyErr result_ty loc) `thenTc_`
- returnTc (fun, lie, result_ty)
-
- -- When we run out of arg_tys we go back to unify_fun in the hope
- -- that our unification work may have shown up some more arguments
- unify_args arg_no fun lie args [] fun_res_ty
- = unify_fun arg_no fun lie args fun_res_ty
-
-
- unify_fun :: Int -- Current argument number
- -> TypecheckedExpr -- Current rebuilt expression
- -> LIE -- Corresponding LIE
- -> [RenamedExpr] -- Remaining args
- -> TauType -- Remaining function type
- -> TcM (TypecheckedExpr, LIE, UniType)
-
- unify_fun arg_no fun lie args fun_ty
- = -- Find out as much as possible about the function
- applyTcSubstToTy fun_ty `thenNF_Tc` \ fun_ty' ->
-
- -- Now see whether it has any arguments
- case (splitTyArgs fun_ty') of
-
- ([], _) -> -- Function has no arguments left
-
- newOpenTyVarTy `thenNF_Tc` \ result_ty ->
- tcExprs e args `thenTc` \ (args', lie_args, arg_tys) ->
-
- -- At this point, a unification error must mean the function is
- -- being applied to too many arguments.
- unifyTauTy fun_ty' (glueTyArgs arg_tys result_ty)
- (TooManyArgsCtxt orig_fun) `thenTc_`
-
- returnTc (build_result_expression fun args',
- lie `plusLIE` lie_args,
- result_ty)
-
- (fun_arg_tys, fun_res_ty) -> -- Function has non-empty list of argument types
-
- unify_args arg_no fun lie args fun_arg_tys fun_res_ty
+ -- Unification can't fail, since we're unifying against a tyvar
+ unifyTauTy fun_ty (mkFunTys arg_tys result_ty) `thenTc_`
+
+ returnTc (args', lie_args, result_ty)
+
+ | otherwise
+ = -- Must be an error: a lurking for-all, or (more commonly)
+ -- a TyConTy... we've applied the function to too many args
+ failTc (tooManyArgs orig_fun)
+
+ where
+ maybe_arrow_ty = getFunTy_maybe fun_ty
+ Just (expected_arg_ty, result_ty) = maybe_arrow_ty
+
+ maybe_tyvar_ty = getTyVar_maybe fun_ty
+ Just fun_tyvar = maybe_tyvar_ty
\end{code}
\begin{code}
-matchArgTy :: E
- -> UniType -- Expected argument type
- -> TypecheckedExpr -- Type checked argument
- -> LIE -- Actual argument LIE
- -> UniType -- Actual argument type
- -> UnifyErrContext
- -> TcM (TypecheckedExpr, -- The incoming type checked arg,
- -- possibly wrapped in a big lambda
- LIE) -- Possibly reduced somewhat
-
-matchArgTy e expected_arg_ty arg_expr actual_arg_lie actual_arg_ty err_ctxt
- | isForAllTy expected_arg_ty
- = -- Ha! The argument type of the function is a for-all type,
- -- An example of rank-2 polymorphism.
-
- -- This applyTcSubstToTy is just to improve the error message..
-
- applyTcSubstToTy actual_arg_ty `thenNF_Tc` \ actual_arg_ty' ->
-
- -- Instantiate the argument type
- -- ToDo: give this a real origin
- specTy UnknownOrigin expected_arg_ty `thenNF_Tc` \ (arg_tyvars, arg_lie, arg_tau) ->
-
- if not (null arg_lie) then
- -- Paranoia check
- panic "Non-null overloading in tcApp"
- else
- -- Assert: arg_lie = []
+tcArg :: TcType s -- Expected arg type
+ -> RenamedHsExpr -- Actual argument
+ -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
+
+tcArg expected_arg_ty arg
+ | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
+ = -- The ordinary, non-rank-2 polymorphic case
+ tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
+ unifyTauTy expected_arg_ty actual_arg_ty `thenTc_`
+ returnTc (arg', lie_arg)
+
+ | otherwise
+ = -- Ha! The argument type of the function is a for-all type,
+ -- An example of rank-2 polymorphism.
- unifyTauTy arg_tau actual_arg_ty' err_ctxt `thenTc_`
+ -- No need to instantiate the argument type... it's must be the result
+ -- 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)
+ let
+ (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
+ in
+ ASSERT( null expected_theta )
+
+ -- 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_` (
-- Check that the arg_tyvars havn't been constrained
-- The interesting bit here is that we must include the free variables
-- 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.
- applyTcSubstAndCollectTyVars
- (tvOfE e `unionLists`
- extractTyVarsFromTy expected_arg_ty) `thenNF_Tc` \ free_tyvars ->
- checkSigTyVars free_tyvars arg_tyvars arg_tau actual_arg_ty rank2_err_ctxt
- `thenTc` \ arg_tyvars' ->
+ 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)
+ expected_tyvars expected_tau actual_arg_ty `thenTc` \ arg_tyvars' ->
-- Check that there's no overloading involved
-- Even if there isn't, there may be some Insts which mention the arg_tyvars,
-- but which, on simplification, don't actually need a dictionary involving
-- the tyvar. So we have to do a proper simplification right here.
- let insts = unMkLIE actual_arg_lie
+ tcSimplifyRank2 (tyVarListToSet arg_tyvars')
+ lie_arg `thenTc` \ (free_insts, inst_binds) ->
+
+ -- This HsLet binds any Insts which came out of the simplification.
+ -- It's a bit out of place here, but using AbsBind involves inventing
+ -- a couple of new names which seems worse.
+ returnTc (TyLam arg_tyvars' (HsLet (mk_binds inst_binds) arg'), free_insts)
+ )
+ where
+
+ mk_binds []
+ = EmptyBinds
+ mk_binds ((inst,rhs):inst_binds)
+ = (SingleBind (NonRecBind (VarMonoBind inst rhs)))
+ `ThenBinds`
+ mk_binds inst_binds
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@tcId@ typchecks an identifier occurrence}
+%* *
+%************************************************************************
+
+\begin{code}
+tcId :: Name -> TcM s (TcExpr s, LIE s, TcType s)
+tcId name
+ = -- Look up the Id and instantiate its type
+ (tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
+ case maybe_local of
+ Just tc_id -> tcInstTcType [] (idType tc_id) `thenNF_Tc` \ ty ->
+ returnNF_Tc (TcId tc_id, ty)
+
+ Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ tcInstType [] (idType id) `thenNF_Tc` \ ty ->
+ returnNF_Tc (RealId id, ty)
+ ) `thenNF_Tc` \ (tc_id_occ, ty) ->
+ let
+ (tyvars, rho) = splitForAllTy ty
+ (theta,tau) = splitRhoTy rho
+ arg_tys = map mkTyVarTy tyvars
in
- applyTcSubstToInsts insts `thenNF_Tc` \ insts' ->
+ -- Is it overloaded?
+ case theta of
+ [] -> -- Not overloaded, so just make a type application
+ returnTc (TyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+
+ _ -> -- Overloaded, so make a Method inst
+ newMethodWithGivenTy (OccurrenceOf tc_id_occ)
+ tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) ->
+ returnTc (HsVar meth_id, lie, tau)
+\end{code}
- tcSimplifyRank2 arg_tyvars' insts' rank2_err_ctxt `thenTc` \ (free_insts, inst_binds) ->
- -- This Let binds any Insts which came out of the simplification.
- -- It's a bit out of place here, but using AbsBind involves inventing
- -- a couple of new names which seems worse.
- returnTc (TyLam arg_tyvars' (Let (mk_binds inst_binds) arg_expr), mkLIE free_insts)
- | otherwise
- = -- The ordinary, non-rank-2 polymorphic case
- unifyTauTy expected_arg_ty actual_arg_ty err_ctxt `thenTc_`
- returnTc (arg_expr, actual_arg_lie)
+%************************************************************************
+%* *
+\subsection{@tcQuals@ typchecks list comprehension qualifiers}
+%* *
+%************************************************************************
+
+\begin{code}
+tcListComp expr []
+ = tcExpr expr `thenTc` \ (expr', lie, ty) ->
+ returnTc ((expr',[]), lie, mkListTy ty)
+
+tcListComp expr (qual@(FilterQual filter) : quals)
+ = tcAddErrCtxt (qualCtxt qual) (
+ tcExpr filter `thenTc` \ (filter', filter_lie, filter_ty) ->
+ unifyTauTy boolTy filter_ty `thenTc_`
+ returnTc (FilterQual filter', filter_lie)
+ ) `thenTc` \ (qual', qual_lie) ->
+
+ tcListComp expr quals `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
+
+ returnTc ((expr', qual' : quals'),
+ qual_lie `plusLIE` rest_lie,
+ res_ty)
+
+tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
+ = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
+
+ tcAddErrCtxt (qualCtxt qual) (
+ tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
+ tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
+ unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_`
+ returnTc (GeneratorQual pat' rhs',
+ lie_pat `plusLIE` lie_rhs)
+ ) `thenTc` \ (qual', lie_qual) ->
+
+ tcListComp expr quals `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
+
+ returnTc ((expr', qual' : quals'),
+ lie_qual `plusLIE` lie_rest,
+ res_ty)
+ )
+ where
+ binder_names = collectPatBinders pat
+tcListComp expr (LetQual binds : quals)
+ = tcBindsAndThen -- No error context, but a binding group is
+ combine -- rather a large thing for an error context anyway
+ binds
+ (tcListComp expr quals)
where
- rank2_err_ctxt = Rank2ArgCtxt arg_expr expected_arg_ty
+ combine binds' (expr',quals') = (expr', LetQual binds' : quals')
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
+%* *
+%************************************************************************
+
+\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)
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ 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)
- mk_binds [] = EmptyBinds
- mk_binds ((inst,rhs):inst_binds) = (SingleBind (NonRecBind (VarMonoBind (mkInstId inst) rhs)))
- `ThenBinds`
- mk_binds inst_binds
\end{code}
-This version only does not check for 2nd order if it is applied.
+%************************************************************************
+%* *
+\subsection{@tcExprs@ typechecks a {\em list} of expressions}
+%* *
+%************************************************************************
\begin{code}
-tcExpr' :: E -> RenamedExpr -> Int -> TcM (TypecheckedExpr,LIE,UniType)
+tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
+
+tcExprs [] = returnTc ([], emptyLIE, [])
+tcExprs (expr:exprs)
+ = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
+ tcExprs exprs `thenTc` \ (exprs', lie2, tys) ->
+ returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
+\end{code}
-tcExpr' e v@(Var name) n
- | n > 0 = specId (lookupE_Value e name) `thenNF_Tc` \ (expr, lie, ty) ->
- returnTc (expr, lie, ty)
-tcExpr' e exp n = tcExpr e exp
+
+% =================================================
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+
+Mini-utils:
+\begin{code}
+pp_nest_hang :: String -> Pretty -> Pretty
+pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
\end{code}
+
+Boring and alphabetical:
+\begin{code}
+arithSeqCtxt expr sty
+ = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
+
+branchCtxt b1 b2 sty
+ = ppSep [ppStr "In the branches of a conditional:",
+ pp_nest_hang "`then' branch:" (ppr sty b1),
+ pp_nest_hang "`else' branch:" (ppr sty b2)]
+
+caseCtxt expr sty
+ = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
+
+exprSigCtxt expr sty
+ = ppHang (ppStr "In an expression with a type signature:")
+ 4 (ppr sty expr)
+
+listCtxt expr sty
+ = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
+
+predCtxt expr sty
+ = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
+
+sectionRAppCtxt expr sty
+ = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
+
+sectionLAppCtxt expr sty
+ = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
+
+funAppCtxt fun arg_no arg sty
+ = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
+ 4 (ppCat [ppStr "namely", ppr sty arg])
+
+qualCtxt qual sty
+ = ppHang (ppStr "In a list-comprehension qualifer:")
+ 4 (ppr sty qual)
+
+stmtCtxt stmt sty
+ = ppHang (ppStr "In a do statement:")
+ 4 (ppr sty stmt)
+
+tooManyArgs f sty
+ = ppHang (ppStr "Too many arguments in an application of the function")
+ 4 (ppr sty f)
+
+lurkingRank2Err fun fun_ty sty
+ = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
+ 4 (ppAboves [ppStr "It is applied to too few arguments,",
+ ppStr "so that the result type has for-alls in it"])
+
+rank2ArgCtxt arg expected_arg_ty sty
+ = ppHang (ppStr "In a polymorphic function argument:")
+ 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
+ ppr sty expected_arg_ty])
+\end{code}
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcGRHSs where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsMatches(GRHSsAndBinds)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcGRHSsAndBinds :: E -> GRHSsAndBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (GRHSsAndBinds Id TypecheckedPat, LIE, UniType)
-
\begin{code}
module TcGRHSs ( tcGRHSsAndBinds ) where
-import TcMonad -- typechecking monad machinery
-import AbsSyn -- the stuff being typechecked
+import Ubiq{-uitous-}
+import TcLoop -- for paranoia checking
-import AbsPrel ( boolTy )
-import E ( growE_LVE, E, LVE(..), TCE(..), UniqFM, CE(..) )
- -- TCE and CE for pragmas only
-import Errors ( UnifyErrContext(..) )
-import LIE ( plusLIE, LIE )
-import TcBinds ( tcLocalBindsAndThen )
+import HsSyn ( GRHSsAndBinds(..), GRHS(..),
+ HsExpr, HsBinds(..), InPat, OutPat, Bind, Sig, Fake )
+import RnHsSyn ( RenamedGRHSsAndBinds(..), RenamedGRHS(..) )
+import TcHsSyn ( TcGRHSsAndBinds(..), TcGRHS(..), TcIdOcc(..) )
+
+import TcMonad
+import Inst ( Inst, LIE(..), plusLIE )
+import TcBinds ( tcBindsAndThen )
import TcExpr ( tcExpr )
+import TcType ( TcType(..) )
import Unify ( unifyTauTy )
-import Util -- pragmas only
+
+import PrelInfo ( boolTy )
\end{code}
\begin{code}
-tcGRHSs :: E -> [RenamedGRHS] -> TcM ([TypecheckedGRHS], LIE, UniType)
+tcGRHSs :: [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s, TcType s)
-tcGRHSs e [grhs]
- = tcGRHS e grhs `thenTc` \ (grhs', lie, ty) ->
+tcGRHSs [grhs]
+ = tcGRHS grhs `thenTc` \ (grhs', lie, ty) ->
returnTc ([grhs'], lie, ty)
-tcGRHSs e gs@(grhs:grhss)
- = tcGRHS e grhs `thenTc` \ (grhs', lie1, ty1) ->
- tcGRHSs e grhss `thenTc` \ (grhss', lie2, ty2) ->
-
- unifyTauTy ty1 ty2 (GRHSsBranchCtxt gs) `thenTc_`
-
+tcGRHSs (grhs:grhss)
+ = tcGRHS grhs `thenTc` \ (grhs', lie1, ty1) ->
+ tcGRHSs grhss `thenTc` \ (grhss', lie2, ty2) ->
+ unifyTauTy ty1 ty2 `thenTc_`
returnTc (grhs' : grhss', lie1 `plusLIE` lie2, ty1)
-tcGRHS e (OtherwiseGRHS expr locn)
- = addSrcLocTc locn (
- tcExpr e expr `thenTc` \ (expr, lie, ty) ->
+tcGRHS (OtherwiseGRHS expr locn)
+ = tcAddSrcLoc locn $
+ tcExpr expr `thenTc` \ (expr, lie, ty) ->
returnTc (OtherwiseGRHS expr locn, lie, ty)
- )
-
-tcGRHS e (GRHS guard expr locn)
- = addSrcLocTc locn (
- tcExpr e guard `thenTc` \ (guard2, guard_lie, guard_ty) ->
-
- unifyTauTy guard_ty boolTy (GRHSsGuardCtxt guard) `thenTc_`
-
- tcExpr e expr `thenTc` \ (expr2, expr_lie, expr_ty) ->
+tcGRHS (GRHS guard expr locn)
+ = tcAddSrcLoc locn $
+ tcExpr guard `thenTc` \ (guard2, guard_lie, guard_ty) ->
+ unifyTauTy boolTy guard_ty `thenTc_`
+ tcExpr expr `thenTc` \ (expr2, expr_lie, expr_ty) ->
returnTc (GRHS guard2 expr2 locn, plusLIE guard_lie expr_lie, expr_ty)
- )
\end{code}
pieces.
\begin{code}
-tcGRHSsAndBinds :: E
- -> RenamedGRHSsAndBinds
- -> TcM (TypecheckedGRHSsAndBinds, LIE, UniType)
-
-tcGRHSsAndBinds e (GRHSsAndBindsIn grhss binds)
- = tcLocalBindsAndThen e
- combiner binds
- (\e -> tcGRHSs e grhss `thenTc` (\ (grhss', lie, ty) ->
- returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie, ty)
- )
+tcGRHSsAndBinds :: RenamedGRHSsAndBinds
+ -> TcM s (TcGRHSsAndBinds s, LIE s, TcType s)
+
+tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
+ = tcBindsAndThen
+ combiner binds
+ (tcGRHSs grhss `thenTc` \ (grhss', lie, ty) ->
+ returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie, ty)
)
where
- combiner binds1 (GRHSsAndBindsOut grhss binds2 ty)
- = GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
+ combiner binds1 (GRHSsAndBindsOut grhss binds2 ty)
+ = GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcGenDeriv where
-import HsBinds(MonoBinds)
-import HsDecls(FixityDecl)
-import HsExpr(Expr)
-import HsPat(InPat)
-import Name(Name)
-import ProtoName(ProtoName)
-import TcDeriv(TagThingWanted)
-import TyCon(TyCon)
-a_Expr :: Expr ProtoName a
-a_PN :: ProtoName
-a_Pat :: InPat ProtoName
-ah_PN :: ProtoName
-b_Expr :: Expr ProtoName a
-b_PN :: ProtoName
-b_Pat :: InPat ProtoName
-bh_PN :: ProtoName
-c_Expr :: Expr ProtoName a
-c_PN :: ProtoName
-c_Pat :: InPat ProtoName
-ch_PN :: ProtoName
-cmp_eq_PN :: ProtoName
-d_Expr :: Expr ProtoName a
-d_PN :: ProtoName
-d_Pat :: InPat ProtoName
-dh_PN :: ProtoName
-eqH_PN :: ProtoName
-eq_TAG_Expr :: Expr ProtoName a
-eq_TAG_PN :: ProtoName
-error_PN :: ProtoName
-false_Expr :: Expr ProtoName a
-false_PN :: ProtoName
-geH_PN :: ProtoName
-gen_Binary_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Enum_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Eq_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Ix_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Ord_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_Text_binds :: [FixityDecl Name] -> Bool -> TyCon -> MonoBinds ProtoName (InPat ProtoName)
-gen_tag_n_con_monobind :: (ProtoName, Name, TyCon, TagThingWanted) -> MonoBinds ProtoName (InPat ProtoName)
-gt_TAG_Expr :: Expr ProtoName a
-gt_TAG_PN :: ProtoName
-leH_PN :: ProtoName
-ltH_PN :: ProtoName
-lt_TAG_Expr :: Expr ProtoName a
-lt_TAG_PN :: ProtoName
-minusH_PN :: ProtoName
-mkInt_PN :: ProtoName
-rangeSize_PN :: ProtoName
-true_Expr :: Expr ProtoName a
-true_PN :: ProtoName
-
d_Pat,
dh_PN,
eqH_PN,
- eq_TAG_Expr,
- eq_TAG_PN,
+ eqTag_Expr,
+ eq_PN,
error_PN,
false_Expr,
false_PN,
gen_Eq_binds,
gen_Ix_binds,
gen_Ord_binds,
- gen_Text_binds,
+ gen_Read_binds,
+ gen_Show_binds,
gen_tag_n_con_monobind,
- gt_TAG_Expr,
- gt_TAG_PN,
+ gtTag_Expr,
+ gt_PN,
leH_PN,
ltH_PN,
- lt_TAG_Expr,
- lt_TAG_PN,
+ ltTag_Expr,
+ lt_PN,
minusH_PN,
mkInt_PN,
rangeSize_PN,
true_Expr,
- true_PN
+ true_PN,
+
+ con2tag_FN, tag2con_FN, maxtag_FN,
+ con2tag_PN, tag2con_PN, maxtag_PN,
+
+ TagThingWanted(..)
) where
-IMPORT_Trace -- ToDo:rm debugging
-import Outputable
-import Pretty
+import Ubiq
-import AbsSyn -- the stuff being typechecked
-
-import AbsPrel
-import PrimOps
-
-import AbsUniType ( getTyConDataCons, isEnumerationTyCon,
- maybeSingleConstructorTyCon, --UNUSED: preludeClassDerivedFor,
- -- UNUSED: isEnumerationTyConMostly,
- isPrimType, UniType,
- TauType(..), TyVarTemplate, ThetaType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Id ( getDataConArity, getDataConTag,
- getDataConSig, isNullaryDataCon, fIRST_TAG,
- isDataCon, DataCon(..), ConTag(..), Id
- )
-import Maybes ( maybeToBool, Maybe(..) )
+import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
+ GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt,
+ ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
+import RdrHsSyn ( ProtoNameMonoBinds(..), ProtoNameHsExpr(..), ProtoNamePat(..) )
+import RnHsSyn ( RenamedFixityDecl(..) )
+
+import RnMonad4 -- initRn4, etc.
+import RnUtils
+
+import Id ( GenId, getDataConArity, getDataConTag,
+ getDataConSig, fIRST_TAG,
+ isDataCon, DataCon(..), ConTag(..) )
+import IdUtils ( primOpId )
+import Maybes ( maybeToBool )
import Name ( Name(..) )
+import NameTypes ( mkFullName, Provenance(..) )
+import Outputable
+import PrimOp
+import PrelInfo
+import Pretty
import ProtoName ( ProtoName(..) )
-import RenameAuxFuns -- why not? take all of it...
-import RenameMonad4 -- initRn4, etc.
import SrcLoc ( mkGeneratedSrcLoc )
-import TcDeriv ( con2tag_PN, tag2con_PN, maxtag_PN,
- TagThingWanted(..), DerivEqn(..)
- )
-import Unique -- some ClassKey stuff
+import TyCon ( TyCon, getTyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
+import Type ( eqTy, isPrimType )
+import Unique
import Util
\end{code}
tycon, we generate:
\begin{verbatim}
instance ... Eq (Foo ...) where
- (==) a b = case (tagCmp a b) of { _LT -> False; _EQ -> True ; _GT -> False}
- (/=) a b = case (tagCmp a b) of { _LT -> True ; _EQ -> False; _GT -> True }
+ (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
+ (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
\begin{verbatim}
However, that requires that \tr{Ord <whatever>} was put in the context
for the instance decl, which it probably wasn't, so the decls
gen_Eq_binds :: TyCon -> ProtoNameMonoBinds
gen_Eq_binds tycon
- = case (partition isNullaryDataCon (getTyConDataCons tycon))
- of { (nullary_cons, nonnullary_cons) ->
+ = case (partition (\ con -> getDataConArity con == 0)
+ (getTyConDataCons tycon))
+ of { (nullary_cons, nonnullary_cons) ->
let
rest
= if null nullary_cons then
- case maybeSingleConstructorTyCon tycon of
+ case maybeTyConSingleCon tycon of
Just _ -> []
Nothing -> -- if cons don't match, then False
[([a_Pat, b_Pat], false_Expr)]
else -- calc. and compare the tags
- [([a_Pat, b_Pat],
+ [([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))]
in
mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest)
`AndMonoBinds` boring_ne_method
}
- where
+ where
------------------------------------------------------------------
pats_etc data_con
= let
bs_needed = take (getDataConArity data_con) bs_PNs
tys_needed = case (getDataConSig data_con) of
(_,_, arg_tys, _) -> arg_tys
- in
+ in
([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
where
nested_eq_expr [] [] [] = true_Expr
- nested_eq_expr [ty] [a] [b] = eq_Expr ty (Var a) (Var b)
+ nested_eq_expr [ty] [a] [b] = eq_Expr ty (HsVar a) (HsVar 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 (Var a) (Var b)) rest_expr
+ and_Expr (eq_Expr t (HsVar a) (HsVar b)) rest_expr
boring_ne_method
= mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] (
- App (Var not_PN) (App (App (Var eq_PN) a_Expr) b_Expr)
+ HsApp (HsVar not_PN) (HsApp (HsApp (HsVar eq_PN) a_Expr) b_Expr)
)
\end{code}
%* *
%************************************************************************
-For a derived @Ord@, we concentrate our attentions on the non-standard
-@_tagCmp@ method, which type:
+For a derived @Ord@, we concentrate our attentions on @compare@
\begin{verbatim}
-_tagCmp :: a -> a -> _CMP_TAG
-
--- and the builtin tag type is:
-
-data _CMP_TAG = _LT | _EQ | _GT deriving ()
+compare :: a -> a -> Ordering
+data Ordering = LT | EQ | GT deriving ()
\end{verbatim}
-(All this @_tagCmp@ stuff is due to the sterling analysis by Julian
-Seward.)
-
We will use the same example data type as above:
\begin{verbatim}
data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
\begin{itemize}
\item
- We do all the other @Ord@ methods with calls to @_tagCmp@:
+ We do all the other @Ord@ methods with calls to @compare@:
\begin{verbatim}
instance ... (Ord <wurble> <wurble>) where
- a < b = case _tagCmp a b of { _LT -> True; _EQ -> False; _GT -> False }
- a <= b = case _tagCmp a b of { _LT -> True; _EQ -> True; _GT -> False }
- a >= b = case _tagCmp a b of { _LT -> False; _EQ -> True; _GT -> True }
- a > b = case _tagCmp 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 _tagCmp a b of { _LT -> b; _EQ -> a; _GT -> a }
- min a b = case _tagCmp a b of { _LT -> a; _EQ -> a; _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 }
- -- _tagCmp to come...
+ -- compare to come...
\end{verbatim}
\item
- @_tagCmp@ always has two parts. First, we use the compared
+ @compare@ always has two parts. First, we use the compared
data-constructors' tags to deal with the case of different
constructors:
\begin{verbatim}
-_tagCmp a b = case (con2tag_Foo a) of { a# ->
- case (con2tag_Foo b) of { b# ->
- case (a# ==# b#) of {
+compare a b = case (con2tag_Foo a) of { a# ->
+ case (con2tag_Foo b) of { b# ->
+ case (a# ==# b#) of {
True -> cmp_eq a b
False -> case (a# <# b#) of
True -> _LT
False -> _GT
- }}}
+ }}}
where
cmp_eq = ... to come ...
\end{verbatim}
comparing data constructors with the same tag.
For the ordinary constructors (if any), we emit the sorta-obvious
- tagCmp-style stuff; for our example:
+ compare-style stuff; for our example:
\begin{verbatim}
cmp_eq (O1 a1 b1) (O1 a2 b2)
- = case (_tagCmp a1 a2) of { _LT -> _LT; _EQ -> _tagCmp b1 b2; _GT -> _GT }
+ = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
cmp_eq (O2 a1) (O2 a2)
- = _tagCmp a1 a2
+ = compare a1 a2
cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
- = case (_tagCmp a1 a2) of {
- _LT -> _LT;
- _GT -> _GT;
- _EQ -> case _tagCmp b1 b2 of {
- _LT -> _LT;
- _GT -> _GT;
- _EQ -> _tagCmp c1 c2
- }
+ = case (compare a1 a2) of {
+ LT -> LT;
+ GT -> GT;
+ EQ -> case compare b1 b2 of {
+ LT -> LT;
+ GT -> GT;
+ EQ -> compare c1 c2
+ }
}
\end{verbatim}
generate:
\begin{verbatim}
cmp_eq lt eq gt (O2 a1) (O2 a2)
- = tagCmpInt# a1 a2
+ = compareInt# a1 a2
-- or maybe the unfolded equivalent
\end{verbatim}
For the remaining nullary constructors, we already know that the
tags are equal so:
\begin{verbatim}
-cmp_eq _ _ = _EQ
+cmp_eq _ _ = EQ
\end{verbatim}
\end{itemize}
gen_Ord_binds :: TyCon -> ProtoNameMonoBinds
gen_Ord_binds tycon
- = defaulted `AndMonoBinds` tagCmp
+ = defaulted `AndMonoBinds` compare
where
--------------------------------------------------------------------
- tagCmp = mk_easy_FunMonoBind tagCmp_PN
+ compare = mk_easy_FunMonoBind compare_PN
[a_Pat, b_Pat]
[cmp_eq]
- (if maybeToBool (maybeSingleConstructorTyCon tycon) then
- cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr
+ (if maybeToBool (maybeTyConSingleCon tycon) then
+ 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
-- If an enumeration type we are done; else
-- recursively compare their components
(if isEnumerationTyCon tycon then
- eq_TAG_Expr
+ eqTag_Expr
else
- cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr
+ cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
)
-- 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 lt_TAG_Expr gt_TAG_Expr)))
+ (cmp_tags_Expr ltH_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
(nullary_cons, nonnullary_cons)
- = partition isNullaryDataCon (getTyConDataCons tycon)
+ = partition (\ con -> getDataConArity con == 0) (getTyConDataCons tycon)
cmp_eq
= mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
where
pats_etc data_con
= ([con1_pat, con2_pat],
- nested_tagCmp_expr tys_needed as_needed bs_needed)
+ nested_compare_expr tys_needed as_needed bs_needed)
where
con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
tys_needed = case (getDataConSig data_con) of
(_,_, arg_tys, _) -> arg_tys
- nested_tagCmp_expr [ty] [a] [b]
- = careful_tagCmp_Case ty lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr (Var a) (Var b)
+ nested_compare_expr [ty] [a] [b]
+ = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
- nested_tagCmp_expr (ty:tys) (a:as) (b:bs)
- = let eq_expr = nested_tagCmp_expr tys as bs
- in careful_tagCmp_Case ty lt_TAG_Expr eq_expr gt_TAG_Expr (Var a) (Var b)
+ nested_compare_expr (ty:tys) (a:as) (b:bs)
+ = let eq_expr = nested_compare_expr tys as bs
+ in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
deflt_pats_etc
= if null nullary_cons
then []
- else [([a_Pat, b_Pat], eq_TAG_Expr)]
+ else [([a_Pat, b_Pat], eqTag_Expr)]
--------------------------------------------------------------------
defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
- tagCmp_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
+ compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
- tagCmp_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
+ compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
- tagCmp_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
+ compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
- tagCmp_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
+ compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
- tagCmp_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
+ compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
- tagCmp_Case a_Expr a_Expr b_Expr a_Expr b_Expr)
+ compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
\end{code}
%************************************************************************
enum_from
= mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] (
untag_Expr tycon [(a_PN, ah_PN)] (
- App (App (Var map_PN) (Var (tag2con_PN tycon))) (
+ HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
enum_from_to_Expr
- (App (Var mkInt_PN) (Var ah_PN))
- (Var (maxtag_PN tycon)))))
+ (HsApp (HsVar mkInt_PN) (HsVar 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)] (
- App (App (Var map_PN) (Var (tag2con_PN tycon))) (
+ HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
enum_from_then_to_Expr
- (App (Var mkInt_PN) (Var ah_PN))
- (App (Var mkInt_PN) (Var bh_PN))
- (Var (maxtag_PN tycon)))))
+ (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
+ (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
+ (HsVar (maxtag_PN tycon)))))
\end{code}
%************************************************************************
-- or, really...
range (a, b)
= case (con2tag_Foo a) of { a# ->
- case (con2tag_Foo b) of { b# ->
+ case (con2tag_Foo b) of { b# ->
map tag2con_Foo (enumFromTo (I# a#) (I# b#))
}}
= mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] (
untag_Expr tycon [(a_PN, ah_PN)] (
untag_Expr tycon [(b_PN, bh_PN)] (
- App (App (Var map_PN) (Var (tag2con_PN tycon))) (
+ HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
enum_from_to_Expr
- (App (Var mkInt_PN) (Var ah_PN))
- (App (Var mkInt_PN) (Var bh_PN))
+ (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
+ (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
))))
enum_index
= mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
- If (App (App (Var inRange_PN) c_Expr) d_Expr) (
+ HsIf (HsApp (HsApp (HsVar inRange_PN) c_Expr) d_Expr) (
untag_Expr tycon [(a_PN, ah_PN)] (
untag_Expr tycon [(d_PN, dh_PN)] (
let
- grhs = [OtherwiseGRHS (App (Var mkInt_PN) (Var c_PN)) mkGeneratedSrcLoc]
+ grhs = [OtherwiseGRHS (HsApp (HsVar mkInt_PN) (HsVar c_PN)) mkGeneratedSrcLoc]
in
- Case (OpApp (Var dh_PN) (Var minusH_PN) (Var ah_PN)) {-of-}
+ HsCase
+ (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN))
[PatMatch (VarPatIn c_PN)
(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
+ mkGeneratedSrcLoc
))
) {-else-} (
- App (Var error_PN) (Lit (StringLit (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
- )
+ HsApp (HsVar error_PN) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
)
+ mkGeneratedSrcLoc)
enum_inRange
= mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
untag_Expr tycon [(a_PN, ah_PN)] (
untag_Expr tycon [(b_PN, bh_PN)] (
untag_Expr tycon [(c_PN, ch_PN)] (
- If (OpApp (Var ch_PN) (Var geH_PN) (Var ah_PN)) (
- (OpApp (Var ch_PN) (Var leH_PN) (Var bh_PN))
+ HsIf (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN)) (
+ (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
) {-else-} (
false_Expr
- )))))
+ ) mkGeneratedSrcLoc))))
--------------------------------------------------------------
single_con_ixes = single_con_range `AndMonoBinds`
single_con_index `AndMonoBinds` single_con_inRange
data_con
- = case maybeSingleConstructorTyCon tycon of -- just checking...
+ = case maybeTyConSingleCon tycon of -- just checking...
Nothing -> panic "get_Ix_binds"
Just dc -> let
(_, _, arg_tys, _) = getDataConSig dc
con_arity = getDataConArity data_con
data_con_PN = Prel (WiredInVal data_con)
con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
- con_expr xs = foldl App (Var data_con_PN) (map Var xs)
+ con_expr xs = foldl HsApp (HsVar data_con_PN) (map HsVar xs)
as_needed = take (getDataConArity data_con) as_PNs
bs_needed = take (getDataConArity data_con) bs_PNs
--------------------------------------------------------------
single_con_range
= mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
- ListComp (con_expr cs_needed) (zipWith3 mk_qual as_needed bs_needed cs_needed)
+ ListComp (con_expr cs_needed) (zipWith3Equal mk_qual as_needed bs_needed cs_needed)
)
where
mk_qual a b c = GeneratorQual (VarPatIn c)
- (App (Var range_PN) (ExplicitTuple [Var a, Var b]))
+ (HsApp (HsVar range_PN) (ExplicitTuple [HsVar a, HsVar b]))
----------------
single_con_index
= mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
- foldl mk_index (Lit (IntLit 0)) (zip3 as_needed bs_needed cs_needed))
+ foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
where
mk_index multiply_by (l, u, i)
=OpApp (
- (App (App (Var index_PN) (ExplicitTuple [Var l, Var u])) (Var i))
- ) (Var plus_PN) (
+ (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
+ ) (HsVar plus_PN) (
OpApp (
- (App (Var rangeSize_PN) (ExplicitTuple [Var l, Var u]))
- ) (Var times_PN) multiply_by
+ (HsApp (HsVar rangeSize_PN) (ExplicitTuple [HsVar l, HsVar u]))
+ ) (HsVar times_PN) multiply_by
)
range_size
= mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
OpApp (
- (App (App (Var index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
- ) (Var plus_PN) (Lit (IntLit 1)))
+ (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
+ ) (HsVar plus_PN) (HsLit (HsInt 1)))
------------------
single_con_inRange
= mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
- foldl1 and_Expr (zipWith3 in_range as_needed bs_needed cs_needed))
+ foldl1 and_Expr (zipWith3Equal in_range as_needed bs_needed cs_needed))
where
- in_range a b c = App (App (Var inRange_PN) (ExplicitTuple [Var a, Var b])) (Var c)
+ in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
\end{code}
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Text]{Generating @Text@ instance declarations}
+\subsubsection[TcGenDeriv-Text]{Generating @Show@ and @Read@ instance declarations}
%* *
%************************************************************************
-Deriving @Text@ is a pain. @show@ is commonly used; @read@ is rarely
-used---but we're supposed to generate massive amounts of code for it
-anyway. We provide a command-line flag to say ``Don't bother''
-(@OmitDerivedRead@).
-
-Also: ignoring all the infix-ery mumbo jumbo (ToDo)
-
-The part of the Haskell report that deals with this (pages~147--151,
-1.2~version) is an adequate guide to what needs to be done. Note that
-this is where we may (eventually) use the fixity info that's been
-passed around.
+Ignoring all the infix-ery mumbo jumbo (ToDo)
\begin{code}
-gen_Text_binds :: [RenamedFixityDecl] -> Bool -> TyCon -> ProtoNameMonoBinds
-
-gen_Text_binds fixities omit_derived_read tycon
- = if omit_derived_read
- then shows_prec `AndMonoBinds` show_list
- else shows_prec `AndMonoBinds` show_list
- `AndMonoBinds`
- reads_prec `AndMonoBinds` read_list
+gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> ProtoNameMonoBinds
+gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> ProtoNameMonoBinds
+
+gen_Read_binds fixities tycon
+ = reads_prec `AndMonoBinds` read_list
where
-----------------------------------------------------------------------
- show_list = mk_easy_FunMonoBind showList_PN [] []
- (App (Var _showList_PN) (App (Var showsPrec_PN) (Lit (IntLit 0))))
-
read_list = mk_easy_FunMonoBind readList_PN [] []
- (App (Var _readList_PN) (App (Var readsPrec_PN) (Lit (IntLit 0))))
-
- -----------------------------------------------------------------------
- shows_prec
- = mk_FunMonoBind showsPrec_PN (map pats_etc (getTyConDataCons tycon))
- where
- pats_etc data_con
- = let
- data_con_PN = Prel (WiredInVal data_con)
- bs_needed = take (getDataConArity data_con) bs_PNs
- con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- is_nullary_con = isNullaryDataCon data_con
-
- show_con
- = let (mod, nm) = getOrigName data_con
- space_maybe = if is_nullary_con then _NIL_ else SLIT(" ")
- in
- App (Var showString_PN) (Lit (StringLit (nm _APPEND_ space_maybe)))
-
- show_thingies = show_con : (spacified real_show_thingies)
-
- real_show_thingies
- = [ App (App (Var showsPrec_PN) (Lit (IntLit 10))) (Var b)
- | b <- bs_needed ]
- in
- if is_nullary_con then -- skip the showParen junk...
- ASSERT(null bs_needed)
- ([a_Pat, con_pat], show_con)
- else
- ([a_Pat, con_pat],
- showParen_Expr (OpApp a_Expr (Var ge_PN) (Lit (IntLit 10)))
- (nested_compose_Expr show_thingies))
- where
- spacified [] = []
- spacified [x] = [x]
- spacified (x:xs) = (x : (Var showSpace_PN) : spacified xs)
-
+ (HsApp (HsVar _readList_PN) (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))
-----------------------------------------------------------------------
- reads_prec -- ignore the infix game altogether
+ reads_prec
= let
read_con_comprehensions
= map read_con (getTyConDataCons tycon)
data_con_str= snd (getOrigName data_con)
as_needed = take (getDataConArity data_con) as_PNs
bs_needed = take (getDataConArity data_con) bs_PNs
- con_expr = foldl App (Var data_con_PN) (map Var as_needed)
- is_nullary_con = isNullaryDataCon data_con
+ con_expr = foldl HsApp (HsVar data_con_PN) (map HsVar as_needed)
+ nullary_con = getDataConArity data_con == 0
con_qual
= GeneratorQual
- (TuplePatIn [LitPatIn (StringLit data_con_str), d_Pat])
- (App (Var lex_PN) c_Expr)
+ (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
+ (HsApp (HsVar lex_PN) c_Expr)
field_quals = snd (mapAccumL mk_qual d_Expr (as_needed `zip` bs_needed))
read_paren_arg
- = if is_nullary_con then -- must be False (parens are surely optional)
+ = if nullary_con then -- must be False (parens are surely optional)
false_Expr
else -- parens depend on precedence...
- OpApp a_Expr (Var gt_PN) (Lit (IntLit 9))
+ OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9))
in
- App (
+ HsApp (
readParen_Expr read_paren_arg (
- Lam (mk_easy_Match [c_Pat] [] (
+ HsLam (mk_easy_Match [c_Pat] [] (
ListComp (ExplicitTuple [con_expr,
- if null bs_needed then d_Expr else Var (last bs_needed)])
+ if null bs_needed then d_Expr else HsVar (last bs_needed)])
(con_qual : field_quals)))
- )) (Var b_PN)
+ )) (HsVar b_PN)
where
mk_qual draw_from (con_field, str_left)
- = (Var str_left, -- what to draw from down the line...
+ = (HsVar str_left, -- what to draw from down the line...
GeneratorQual
(TuplePatIn [VarPatIn con_field, VarPatIn str_left])
- (App (App (Var readsPrec_PN) (Lit (IntLit 10))) draw_from))
+ (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
+
+
+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))))
+ -----------------------------------------------------------------------
+ shows_prec
+ = mk_FunMonoBind showsPrec_PN (map pats_etc (getTyConDataCons tycon))
+ where
+ pats_etc data_con
+ = let
+ data_con_PN = Prel (WiredInVal data_con)
+ bs_needed = take (getDataConArity data_con) bs_PNs
+ con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
+ nullary_con = getDataConArity data_con == 0
+
+ show_con
+ = let (mod, nm) = getOrigName data_con
+ space_maybe = if nullary_con then _NIL_ else SLIT(" ")
+ in
+ HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe)))
+
+ show_thingies = show_con : (spacified real_show_thingies)
+
+ real_show_thingies
+ = [ HsApp (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 10))) (HsVar b)
+ | b <- bs_needed ]
+ in
+ if nullary_con then -- skip the showParen junk...
+ ASSERT(null bs_needed)
+ ([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))
+ where
+ spacified [] = []
+ spacified [x] = [x]
+ spacified (x:xs) = (x : (HsVar showSpace_PN) : spacified xs)
\end{code}
%************************************************************************
fiddling around.
\begin{code}
+data TagThingWanted
+ = GenCon2Tag | GenTag2Con | GenMaxTag
+
gen_tag_n_con_monobind
:: (ProtoName, Name, -- (proto)Name for the thing in question
TyCon, -- tycon in question
gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
= mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
where
- mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
+ mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
mk_stuff var
= ASSERT(isDataCon var)
- ([pat], Lit (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG))))
+ ([pat], HsLit (HsIntPrim (toInteger ((getDataConTag var) - fIRST_TAG))))
where
pat = ConPatIn var_PN (nOfThem (getDataConArity var) WildPatIn)
var_PN = Prel (WiredInVal var)
gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
= mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
where
- mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
+ mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
mk_stuff var
= ASSERT(isDataCon var)
- ([lit_pat], Var var_PN)
+ ([lit_pat], HsVar var_PN)
where
- lit_pat = ConPatIn mkInt_PN [LitPatIn (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG)))]
+ lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((getDataConTag var) - fIRST_TAG)))]
var_PN = Prel (WiredInVal var)
gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
- = mk_easy_FunMonoBind pn [] [] (App (Var mkInt_PN) (Lit (IntPrimLit max_tag)))
+ = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
where
max_tag = case (getTyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
\begin{code}
mk_easy_FunMonoBind :: ProtoName -> [ProtoNamePat]
- -> [ProtoNameMonoBinds] -> ProtoNameExpr
+ -> [ProtoNameMonoBinds] -> ProtoNameHsExpr
-> ProtoNameMonoBinds
mk_easy_FunMonoBind fun pats binds expr
(GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds)))
pats
where
- mkbind [] = EmptyBinds
+ mkbind [] = EmptyBinds
mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
-- The renamer expects everything in its input to be a
-- "recursive" MonoBinds, and it is its job to sort things out
-- from there.
mk_FunMonoBind :: ProtoName
- -> [([ProtoNamePat], ProtoNameExpr)]
+ -> [([ProtoNamePat], ProtoNameHsExpr)]
-> ProtoNameMonoBinds
mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
\end{code}
\begin{code}
-tagCmp_Case, cmp_eq_Expr ::
- ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
- -> ProtoNameExpr -> ProtoNameExpr
- -> ProtoNameExpr
-tagCmp_gen_Case ::
+compare_Case, cmp_eq_Expr ::
+ ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+ -> ProtoNameHsExpr -> ProtoNameHsExpr
+ -> ProtoNameHsExpr
+compare_gen_Case ::
ProtoName
- -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
- -> ProtoNameExpr -> ProtoNameExpr
- -> ProtoNameExpr
-careful_tagCmp_Case :: -- checks for primitive types...
- UniType
- -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
- -> ProtoNameExpr -> ProtoNameExpr
- -> ProtoNameExpr
-
-tagCmp_Case = tagCmp_gen_Case tagCmp_PN
-cmp_eq_Expr = tagCmp_gen_Case cmp_eq_PN
-
-tagCmp_gen_Case fun lt eq gt a b
- = Case (App (App (Var fun) a) b) {-of-}
- [PatMatch (ConPatIn lt_TAG_PN [])
+ -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+ -> ProtoNameHsExpr -> ProtoNameHsExpr
+ -> ProtoNameHsExpr
+careful_compare_Case :: -- checks for primitive types...
+ Type
+ -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+ -> ProtoNameHsExpr -> ProtoNameHsExpr
+ -> ProtoNameHsExpr
+
+compare_Case = compare_gen_Case compare_PN
+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-}
+ [PatMatch (ConPatIn ltTag_PN [])
(GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
- PatMatch (ConPatIn eq_TAG_PN [])
+ PatMatch (ConPatIn eqTag_PN [])
(GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
- PatMatch (ConPatIn gt_TAG_PN [])
+ PatMatch (ConPatIn gtTag_PN [])
(GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
+ mkGeneratedSrcLoc
-careful_tagCmp_Case ty lt eq gt a b
+careful_compare_Case ty lt eq gt a b
= if not (isPrimType ty) then
- tagCmp_gen_Case tagCmp_PN lt eq gt a b
+ compare_gen_Case compare_PN lt eq gt a b
else -- we have to do something special for primitive things...
- If (OpApp a (Var relevant_eq_op) b)
- eq
- (If (OpApp a (Var relevant_lt_op) b) lt gt)
+ HsIf (OpApp a (HsVar relevant_eq_op) b)
+ eq
+ (HsIf (OpApp a (HsVar relevant_lt_op) b) lt gt mkGeneratedSrcLoc)
+ mkGeneratedSrcLoc
where
- relevant_eq_op = assoc "careful_tagCmp_Case" eq_op_tbl ty
- relevant_lt_op = assoc "careful_tagCmp_Case" lt_op_tbl ty
+ relevant_eq_op = assoc_ty_id eq_op_tbl ty
+ relevant_lt_op = assoc_ty_id lt_op_tbl ty
+
+assoc_ty_id tyids ty
+ = if null res then panic "assoc_ty"
+ else head res
+ where
+ res = [id | (ty',id) <- tyids, eqTy ty ty']
eq_op_tbl = [
(charPrimTy, Prel (WiredInVal (primOpId CharEqOp))),
-----------------------------------------------------------------------
-and_Expr, append_Expr :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
+and_Expr, append_Expr :: ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
-and_Expr a b = OpApp a (Var and_PN) b
-append_Expr a b = OpApp a (Var append_PN) b
+and_Expr a b = OpApp a (HsVar and_PN) b
+append_Expr a b = OpApp a (HsVar append_PN) b
-----------------------------------------------------------------------
-eq_Expr :: UniType -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
+eq_Expr :: Type -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
eq_Expr ty a b
= if not (isPrimType ty) then
- OpApp a (Var eq_PN) b
+ OpApp a (HsVar eq_PN) b
else -- we have to do something special for primitive things...
- OpApp a (Var relevant_eq_op) b
+ OpApp a (HsVar relevant_eq_op) b
where
- relevant_eq_op = assoc "eq_Expr" eq_op_tbl ty
+ relevant_eq_op = assoc_ty_id eq_op_tbl ty
\end{code}
\begin{code}
-untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameExpr -> ProtoNameExpr
+untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameHsExpr -> ProtoNameHsExpr
untag_Expr tycon [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
- = Case (App (con2tag_Expr tycon) (Var untag_this)) {-of-}
+ = HsCase (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 :: ProtoName -- Comparison op
-> ProtoName -> ProtoName -- Things to compare
- -> ProtoNameExpr -- What to return if true
- -> ProtoNameExpr -- What to return if false
- -> ProtoNameExpr
+ -> ProtoNameHsExpr -- What to return if true
+ -> ProtoNameHsExpr -- What to return if false
+ -> ProtoNameHsExpr
-cmp_tags_Expr op a b true_case false_case
- = If (OpApp (Var a) (Var op) (Var b)) true_case false_case
+cmp_tags_Expr op a b true_case false_case
+ = HsIf (OpApp (HsVar a) (HsVar op) (HsVar b)) true_case false_case mkGeneratedSrcLoc
enum_from_to_Expr
- :: ProtoNameExpr -> ProtoNameExpr
- -> ProtoNameExpr
+ :: ProtoNameHsExpr -> ProtoNameHsExpr
+ -> ProtoNameHsExpr
enum_from_then_to_Expr
- :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
- -> ProtoNameExpr
+ :: ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+ -> ProtoNameHsExpr
-enum_from_to_Expr f t2 = App (App (Var enumFromTo_PN) f) t2
-enum_from_then_to_Expr f t t2 = App (App (App (Var enumFromThenTo_PN) f) t) t2
+enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_PN) f) t2
+enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_PN) f) t) t2
showParen_Expr, readParen_Expr
- :: ProtoNameExpr -> ProtoNameExpr
- -> ProtoNameExpr
+ :: ProtoNameHsExpr -> ProtoNameHsExpr
+ -> ProtoNameHsExpr
-showParen_Expr e1 e2 = App (App (Var showParen_PN) e1) e2
-readParen_Expr e1 e2 = App (App (Var readParen_PN) e1) e2
+showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2
+readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
-nested_compose_Expr :: [ProtoNameExpr] -> ProtoNameExpr
+nested_compose_Expr :: [ProtoNameHsExpr] -> ProtoNameHsExpr
nested_compose_Expr [e] = e
nested_compose_Expr (e:es)
- = App (App (Var compose_PN) e) (nested_compose_Expr es)
+ = HsApp (HsApp (HsVar compose_PN) e) (nested_compose_Expr es)
\end{code}
\begin{code}
gt_PN = prelude_method SLIT("Ord") SLIT(">")
max_PN = prelude_method SLIT("Ord") SLIT("max")
min_PN = prelude_method SLIT("Ord") SLIT("min")
-tagCmp_PN = prelude_method SLIT("Ord") SLIT("_tagCmp")
-lt_TAG_PN = Prel (WiredInVal ltPrimDataCon)
-eq_TAG_PN = Prel (WiredInVal eqPrimDataCon)
-gt_TAG_PN = Prel (WiredInVal gtPrimDataCon)
+compare_PN = prelude_method SLIT("Ord") SLIT("compare")
+ltTag_PN = Prel (WiredInVal ltDataCon)
+eqTag_PN = Prel (WiredInVal eqDataCon)
+gtTag_PN = Prel (WiredInVal gtDataCon)
enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom")
enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo")
enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen")
range_PN = prelude_method SLIT("Ix") SLIT("range")
index_PN = prelude_method SLIT("Ix") SLIT("index")
inRange_PN = prelude_method SLIT("Ix") SLIT("inRange")
-readsPrec_PN = prelude_method SLIT("Text") SLIT("readsPrec")
-showsPrec_PN = prelude_method SLIT("Text") SLIT("showsPrec")
-readList_PN = prelude_method SLIT("Text") SLIT("readList")
-showList_PN = prelude_method SLIT("Text") SLIT("showList")
+readsPrec_PN = prelude_method SLIT("Read") SLIT("readsPrec")
+readList_PN = prelude_method SLIT("Read") SLIT("readList")
+showsPrec_PN = prelude_method SLIT("Show") SLIT("showsPrec")
+showList_PN = prelude_method SLIT("Show") SLIT("showList")
plus_PN = prelude_method SLIT("Num") SLIT("+")
times_PN = prelude_method SLIT("Num") SLIT("*")
prelude_val m s = Imp m s [m] s
prelude_method c o = Imp pRELUDE_CORE o [pRELUDE_CORE] o -- class not used...
-a_Expr = Var a_PN
-b_Expr = Var b_PN
-c_Expr = Var c_PN
-d_Expr = Var d_PN
-lt_TAG_Expr = Var lt_TAG_PN
-eq_TAG_Expr = Var eq_TAG_PN
-gt_TAG_Expr = Var gt_TAG_PN
-false_Expr = Var false_PN
-true_Expr = Var true_PN
+a_Expr = HsVar a_PN
+b_Expr = HsVar b_PN
+c_Expr = HsVar c_PN
+d_Expr = HsVar d_PN
+ltTag_Expr = HsVar ltTag_PN
+eqTag_Expr = HsVar eqTag_PN
+gtTag_Expr = HsVar gtTag_PN
+false_Expr = HsVar false_PN
+true_Expr = HsVar true_PN
-con2tag_Expr tycon = Var (con2tag_PN tycon)
+con2tag_Expr tycon = HsVar (con2tag_PN tycon)
a_Pat = VarPatIn a_PN
b_Pat = VarPatIn b_PN
c_Pat = VarPatIn c_PN
d_Pat = VarPatIn d_PN
-\end{code}
-%************************************************************************
-%* *
-\subsection[TcGenDeriv-misc-utils]{Miscellaneous utility bits for deriving}
-%* *
-%************************************************************************
-\begin{code}
-{- UNUSED:
-hasCon2TagFun :: TyCon -> Bool
-hasCon2TagFun tycon
- = preludeClassDerivedFor ordClassKey tycon
- || isEnumerationTyConMostly tycon
-
-hasTag2ConFun :: TyCon -> Bool
-hasTag2ConFun tycon
- = isEnumerationTyCon tycon
- && (preludeClassDerivedFor ixClassKey tycon
- || preludeClassDerivedFor enumClassKey tycon)
--}
+con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> ProtoName
+
+con2tag_PN tycon
+ = let (mod, nm) = getOrigName tycon
+ con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
+ in
+ Imp mod con2tag [mod] con2tag
+
+tag2con_PN tycon
+ = let (mod, nm) = getOrigName tycon
+ tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
+ in
+ Imp mod tag2con [mod] tag2con
+
+maxtag_PN tycon
+ = let (mod, nm) = getOrigName tycon
+ maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
+ in
+ Imp mod maxtag [mod] maxtag
+
+
+con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> FullName
+
+tag2con_FN tycon
+ = let (mod, nm) = getOrigName tycon
+ tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
+ in
+ mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc
+
+maxtag_FN tycon
+ = let (mod, nm) = getOrigName tycon
+ maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
+ in
+ mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc
+
+con2tag_FN tycon
+ = let (mod, nm) = getOrigName tycon
+ con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
+ in
+ mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc
+
\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
+
+This module is an extension of @HsSyn@ syntax, for use in the type
+checker.
+
+\begin{code}
+module TcHsSyn (
+ TcIdBndr(..), TcIdOcc(..),
+
+ TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..), TcExpr(..), TcGRHSsAndBinds(..),
+ TcGRHS(..), TcMatch(..), TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcHsModule(..),
+
+ TypecheckedHsBinds(..), TypecheckedBind(..), TypecheckedMonoBinds(..),
+ TypecheckedPat(..), TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..),
+ TypecheckedQual(..), TypecheckedStmt(..), TypecheckedMatch(..),
+ TypecheckedHsModule(..), TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
+
+ mkHsTyApp, mkHsDictApp,
+ mkHsTyLam, mkHsDictLam,
+
+ zonkBinds,
+ zonkInst,
+ zonkId, -- TcIdBndr s -> NF_TcM s Id
+ unZonkId -- Id -> NF_TcM s (TcIdBndr s)
+ ) where
+
+import Ubiq{-uitous-}
+
+-- friends:
+import HsSyn -- oodles of it
+import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
+ DictVar(..)
+ )
+
+-- others:
+import TcMonad
+import TcType ( TcType(..), TcMaybe, TcTyVar(..),
+ zonkTcTypeToType, zonkTcTyVarToTyVar,
+ tcInstType
+ )
+import Usage ( UVar(..) )
+import Util ( panic )
+
+import PprType ( GenType, GenTyVar ) -- instances
+import TyVar ( GenTyVar ) -- instances
+import Unique ( Unique ) -- instances
+\end{code}
+
+
+Type definitions
+~~~~~~~~~~~~~~~~
+
+The @Tc...@ datatypes are the ones that apply {\em during} type checking.
+All the types in @Tc...@ things have mutable type-variables in them for
+unification.
+
+At the end of type checking we zonk everything to @Typechecked...@ datatypes,
+which have immutable type variables in them.
+
+\begin{code}
+type TcIdBndr s = GenId (TcType s) -- Binders are all TcTypes
+data TcIdOcc s = TcId (TcIdBndr s) -- Bindees may be either
+ | RealId Id
+
+type TcHsBinds s = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcBind s = Bind (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcPat s = OutPat (TcTyVar s) UVar (TcIdOcc s)
+type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcQual s = Qual (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+
+type TypecheckedPat = OutPat TyVar UVar Id
+type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat
+type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat
+type TypecheckedBind = Bind TyVar UVar Id TypecheckedPat
+type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat
+type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat
+type TypecheckedQual = Qual TyVar UVar Id TypecheckedPat
+type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat
+type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat
+type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat
+type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat
+type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat
+\end{code}
+
+\begin{code}
+mkHsTyApp expr [] = expr
+mkHsTyApp expr tys = TyApp expr tys
+
+mkHsDictApp expr [] = expr
+mkHsDictApp expr dict_vars = DictApp expr dict_vars
+
+mkHsTyLam [] expr = expr
+mkHsTyLam tyvars expr = TyLam tyvars expr
+
+mkHsDictLam [] expr = expr
+mkHsDictLam dicts expr = DictLam dicts expr
+\end{code}
+
+
+
+\begin{code}
+instance Eq (TcIdOcc s) where
+ (TcId id1) == (TcId id2) = id1 == id2
+ (RealId id1) == (RealId id2) = id1 == id2
+
+instance Outputable (TcIdOcc s) where
+ ppr sty (TcId id) = ppr sty id
+ ppr sty (RealId id) = ppr sty id
+
+instance NamedThing (TcIdOcc s) where
+ getOccurrenceName (TcId id) = getOccurrenceName id
+ getOccurrenceName (RealId id) = getOccurrenceName id
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
+%* *
+%************************************************************************
+
+\begin{code}
+zonkId :: TcIdOcc s -> NF_TcM s Id
+unZonkId :: Id -> NF_TcM s (TcIdBndr s)
+
+zonkId (RealId id) = returnNF_Tc id
+
+zonkId (TcId (Id u ty details prags info))
+ = zonkTcTypeToType ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (Id u ty' details prags info)
+
+unZonkId (Id u ty details prags info)
+ = tcInstType [] ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (Id u ty' details prags info)
+\end{code}
+
+\begin{code}
+zonkInst :: (TcIdOcc s, TcExpr s) -> NF_TcM s (Id, TypecheckedHsExpr)
+zonkInst (id, expr)
+ = zonkId id `thenNF_Tc` \ id' ->
+ zonkExpr expr `thenNF_Tc` \ expr' ->
+ returnNF_Tc (id', expr')
+\end{code}
+
+\begin{code}
+zonkBinds :: TcHsBinds s -> NF_TcM s TypecheckedHsBinds
+
+zonkBinds EmptyBinds = returnNF_Tc EmptyBinds
+
+zonkBinds (ThenBinds binds1 binds2)
+ = zonkBinds binds1 `thenNF_Tc` \ new_binds1 ->
+ zonkBinds binds2 `thenNF_Tc` \ new_binds2 ->
+ returnNF_Tc (ThenBinds new_binds1 new_binds2)
+
+zonkBinds (SingleBind bind)
+ = zonkBind bind `thenNF_Tc` \ new_bind ->
+ returnNF_Tc (SingleBind new_bind)
+
+zonkBinds (AbsBinds tyvars dicts locprs dict_binds val_bind)
+ = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
+ mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
+ mapNF_Tc subst_pair locprs `thenNF_Tc` \ new_locprs ->
+ mapNF_Tc subst_bind dict_binds `thenNF_Tc` \ new_dict_binds ->
+ zonkBind val_bind `thenNF_Tc` \ new_val_bind ->
+ returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind)
+ where
+ subst_pair (l, g)
+ = zonkId l `thenNF_Tc` \ new_l ->
+ zonkId g `thenNF_Tc` \ new_g ->
+ returnNF_Tc (new_l, new_g)
+
+ subst_bind (v, e)
+ = zonkId v `thenNF_Tc` \ new_v ->
+ zonkExpr e `thenNF_Tc` \ new_e ->
+ returnNF_Tc (new_v, new_e)
+\end{code}
+
+\begin{code}
+-------------------------------------------------------------------------
+zonkBind :: TcBind s -> NF_TcM s TypecheckedBind
+
+zonkBind EmptyBind = returnNF_Tc EmptyBind
+
+zonkBind (NonRecBind mbinds)
+ = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
+ returnNF_Tc (NonRecBind new_mbinds)
+
+zonkBind (RecBind mbinds)
+ = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
+ returnNF_Tc (RecBind new_mbinds)
+
+-------------------------------------------------------------------------
+zonkMonoBinds :: TcMonoBinds s -> NF_TcM s TypecheckedMonoBinds
+
+zonkMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds
+
+zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
+ = zonkMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 ->
+ zonkMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 ->
+ returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2)
+
+zonkMonoBinds (PatMonoBind pat grhss_w_binds locn)
+ = zonkPat pat `thenNF_Tc` \ new_pat ->
+ zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
+ returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn)
+
+zonkMonoBinds (VarMonoBind var expr)
+ = zonkId var `thenNF_Tc` \ new_var ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (VarMonoBind new_var new_expr)
+
+zonkMonoBinds (FunMonoBind name ms locn)
+ = zonkId name `thenNF_Tc` \ new_name ->
+ mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (FunMonoBind new_name new_ms locn)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
+%* *
+%************************************************************************
+
+\begin{code}
+zonkMatch :: TcMatch s -> NF_TcM s TypecheckedMatch
+
+zonkMatch (PatMatch pat match)
+ = zonkPat pat `thenNF_Tc` \ new_pat ->
+ zonkMatch match `thenNF_Tc` \ new_match ->
+ returnNF_Tc (PatMatch new_pat new_match)
+
+zonkMatch (GRHSMatch grhss_w_binds)
+ = zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
+ returnNF_Tc (GRHSMatch new_grhss_w_binds)
+
+-------------------------------------------------------------------------
+zonkGRHSsAndBinds :: TcGRHSsAndBinds s
+ -> NF_TcM s TypecheckedGRHSsAndBinds
+
+zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty)
+ = mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
+ zonkBinds binds `thenNF_Tc` \ new_binds ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
+ where
+ zonk_grhs (GRHS guard expr locn)
+ = zonkExpr guard `thenNF_Tc` \ new_guard ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (GRHS new_guard new_expr locn)
+
+ zonk_grhs (OtherwiseGRHS expr locn)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (OtherwiseGRHS new_expr locn)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
+%* *
+%************************************************************************
+
+ToDo: panic on things that can't be in @TypecheckedHsExpr@.
+
+\begin{code}
+zonkExpr :: TcExpr s -> NF_TcM s TypecheckedHsExpr
+
+zonkExpr (HsVar name)
+ = zonkId name `thenNF_Tc` \ new_name ->
+ returnNF_Tc (HsVar new_name)
+
+zonkExpr (HsLitOut lit ty)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (HsLitOut lit new_ty)
+
+zonkExpr (HsLam match)
+ = zonkMatch match `thenNF_Tc` \ new_match ->
+ returnNF_Tc (HsLam new_match)
+
+zonkExpr (HsApp e1 e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (HsApp new_e1 new_e2)
+
+zonkExpr (OpApp e1 op e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr op `thenNF_Tc` \ new_op ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (OpApp new_e1 new_op new_e2)
+
+zonkExpr (SectionL expr op)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkExpr op `thenNF_Tc` \ new_op ->
+ returnNF_Tc (SectionL new_expr new_op)
+
+zonkExpr (SectionR op expr)
+ = zonkExpr op `thenNF_Tc` \ new_op ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (SectionR new_op new_expr)
+
+zonkExpr (CCall fun args may_gc is_casm result_ty)
+ = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
+ zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
+ returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
+
+zonkExpr (HsSCC label expr)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (HsSCC label new_expr)
+
+zonkExpr (HsCase expr ms src_loc)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (HsCase new_expr new_ms src_loc)
+
+zonkExpr (HsLet binds expr)
+ = zonkBinds binds `thenNF_Tc` \ new_binds ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (HsLet new_binds new_expr)
+
+zonkExpr (HsDoOut stmts m_id mz_id src_loc)
+ = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
+ zonkId m_id `thenNF_Tc` \ m_new ->
+ zonkId mz_id `thenNF_Tc` \ mz_new ->
+ returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc)
+
+zonkExpr (ListComp expr quals)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkQuals quals `thenNF_Tc` \ new_quals ->
+ returnNF_Tc (ListComp new_expr new_quals)
+
+--ExplicitList: not in typechecked exprs
+
+zonkExpr (ExplicitListOut ty exprs)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
+ returnNF_Tc (ExplicitListOut new_ty new_exprs)
+
+zonkExpr (ExplicitTuple exprs)
+ = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
+ returnNF_Tc (ExplicitTuple new_exprs)
+
+zonkExpr (RecordCon con rbinds)
+ = panic "zonkExpr:RecordCon"
+zonkExpr (RecordUpd exp rbinds)
+ = panic "zonkExpr:RecordUpd"
+
+zonkExpr (HsIf e1 e2 e3 src_loc)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ zonkExpr e3 `thenNF_Tc` \ new_e3 ->
+ returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
+
+zonkExpr (ArithSeqOut expr info)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkArithSeq info `thenNF_Tc` \ new_info ->
+ returnNF_Tc (ArithSeqOut new_expr new_info)
+
+zonkExpr (TyLam tyvars expr)
+ = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (TyLam new_tyvars new_expr)
+
+zonkExpr (TyApp expr tys)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
+ returnNF_Tc (TyApp new_expr new_tys)
+
+zonkExpr (DictLam dicts expr)
+ = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (DictLam new_dicts new_expr)
+
+zonkExpr (DictApp expr dicts)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
+ returnNF_Tc (DictApp new_expr new_dicts)
+
+zonkExpr (ClassDictLam dicts methods expr)
+ = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
+ mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
+
+zonkExpr (Dictionary dicts methods)
+ = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
+ mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods ->
+ returnNF_Tc (Dictionary new_dicts new_methods)
+
+zonkExpr (SingleDict name)
+ = zonkId name `thenNF_Tc` \ new_name ->
+ returnNF_Tc (SingleDict new_name)
+
+-------------------------------------------------------------------------
+zonkArithSeq :: TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
+
+zonkArithSeq (From e)
+ = zonkExpr e `thenNF_Tc` \ new_e ->
+ returnNF_Tc (From new_e)
+
+zonkArithSeq (FromThen e1 e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (FromThen new_e1 new_e2)
+
+zonkArithSeq (FromTo e1 e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (FromTo new_e1 new_e2)
+
+zonkArithSeq (FromThenTo e1 e2 e3)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ zonkExpr e3 `thenNF_Tc` \ new_e3 ->
+ returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
+
+-------------------------------------------------------------------------
+zonkQuals :: [TcQual s] -> NF_TcM s [TypecheckedQual]
+
+zonkQuals quals
+ = mapNF_Tc zonk_qual quals
+ where
+ zonk_qual (GeneratorQual pat expr)
+ = zonkPat pat `thenNF_Tc` \ new_pat ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (GeneratorQual new_pat new_expr)
+
+ zonk_qual (FilterQual expr)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (FilterQual new_expr)
+
+ zonk_qual (LetQual binds)
+ = zonkBinds binds `thenNF_Tc` \ new_binds ->
+ returnNF_Tc (LetQual new_binds)
+
+-------------------------------------------------------------------------
+zonkStmts :: [TcStmt s] -> NF_TcM s [TypecheckedStmt]
+
+zonkStmts stmts
+ = mapNF_Tc zonk_stmt stmts
+ where
+ zonk_stmt (BindStmt pat expr src_loc)
+ = zonkPat pat `thenNF_Tc` \ new_pat ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (BindStmt new_pat new_expr src_loc)
+
+ zonk_stmt (ExprStmt expr src_loc)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (ExprStmt new_expr src_loc)
+
+ zonk_stmt (LetStmt binds)
+ = zonkBinds binds `thenNF_Tc` \ new_binds ->
+ returnNF_Tc (LetStmt new_binds)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[BackSubst-Pats]{Patterns}
+%* *
+%************************************************************************
+
+\begin{code}
+zonkPat :: TcPat s -> NF_TcM s TypecheckedPat
+
+zonkPat (WildPat ty)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (WildPat new_ty)
+
+zonkPat (VarPat v)
+ = zonkId v `thenNF_Tc` \ new_v ->
+ returnNF_Tc (VarPat new_v)
+
+zonkPat (LazyPat pat)
+ = zonkPat pat `thenNF_Tc` \ new_pat ->
+ returnNF_Tc (LazyPat new_pat)
+
+zonkPat (AsPat n pat)
+ = zonkId n `thenNF_Tc` \ new_n ->
+ zonkPat pat `thenNF_Tc` \ new_pat ->
+ returnNF_Tc (AsPat new_n new_pat)
+
+zonkPat (ConPat n ty pats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
+ returnNF_Tc (ConPat n new_ty new_pats)
+
+zonkPat (ConOpPat pat1 op pat2 ty)
+ = zonkPat pat1 `thenNF_Tc` \ new_pat1 ->
+ zonkPat pat2 `thenNF_Tc` \ new_pat2 ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty)
+
+zonkPat (ListPat ty pats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
+ returnNF_Tc (ListPat new_ty new_pats)
+
+zonkPat (TuplePat pats)
+ = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
+ returnNF_Tc (TuplePat new_pats)
+
+zonkPat (LitPat lit ty)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (LitPat lit new_ty)
+
+zonkPat (NPat lit ty expr)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (NPat lit new_ty new_expr)
+
+zonkPat (DictPat ds ms)
+ = mapNF_Tc zonkId ds `thenNF_Tc` \ new_ds ->
+ mapNF_Tc zonkId ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (DictPat new_ds new_ms)
+\end{code}
+
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcIfaceSig where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(Sig)
-import Id(Id)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-tcInterfaceSigs :: E -> [Sig Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Name, Id)]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcIfaceSig]{Type checking of type signatures in interface files}
module TcIfaceSig ( tcInterfaceSigs ) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
+import Ubiq
+
+import TcMonad
+import TcMonoType ( tcPolyType )
+
+import HsSyn ( Sig(..), PolyType )
+import RnHsSyn ( RenamedSig(..) )
+
+import CmdLineOpts ( opt_CompilingPrelude )
+import Id ( mkImported )
+import Name ( Name(..) )
import Pretty
+import Util ( panic )
+
+
+--import TcPragmas ( tcGenPragmas )
+import IdInfo ( noIdInfo )
+tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-import TcMonad -- typechecking monadic machinery
-import AbsSyn -- the stuff being typechecked
-
-import AbsUniType ( splitType, splitTyArgs )
-import CmdLineOpts ( GlobalSwitch(..) )
-import E ( getE_CE, getE_TCE, nullGVE, unitGVE,
- plusGVE, GVE(..), E, CE(..), TCE(..), UniqFM
- )
-import Errors ( confusedNameErr )
-import Id -- mkImported
-#if USE_ATTACK_PRAGMAS
-import IdInfo ( workerExists )
-#endif
-import Maybes ( Maybe(..) )
-import TcPragmas ( tcGenPragmas )
-import TVE ( nullTVE, TVE(..) )
-import TcPolyType ( tcPolyType )
-import UniqFM ( emptyUFM ) -- profiling, pragmas only
-import Util
\end{code}
Ultimately, type signatures in interfaces will have pragmatic
signatures.
\begin{code}
-tcInterfaceSigs :: E -> [RenamedSig] -> Baby_TcM GVE
-
-tcInterfaceSigs e [] = returnB_Tc nullGVE
-
-tcInterfaceSigs e (sig:sigs)
- = tc_sig sig `thenB_Tc` \ gve1 ->
- tcInterfaceSigs e sigs `thenB_Tc` \ gve2 ->
- returnB_Tc (plusGVE gve1 gve2)
- where
- ce = getE_CE e
- tce = getE_TCE e
-
- tc_sig (Sig name@(OtherTopId uniq full_name) ty pragmas src_loc)
- = addSrcLocB_Tc src_loc (
- tcPolyType ce tce nullTVE ty `thenB_Tc` \ sigma_ty ->
-
- fixB_Tc ( \ rec_imported_id ->
- tcGenPragmas e (Just sigma_ty) rec_imported_id pragmas
- `thenB_Tc` \ id_info ->
-
- returnB_Tc (mkImported uniq full_name sigma_ty id_info)
- ) `thenB_Tc` \ final_id ->
-
- returnB_Tc (unitGVE name final_id)
- )
-
- tc_sig (Sig odd_name _ _ src_loc)
- = getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr ->
- case odd_name of
- WiredInVal _ | sw_chkr CompilingPrelude -- OK, that's cool; ignore
- -> returnB_Tc nullGVE
- _ -> failB_Tc (confusedNameErr "Bad name on a type signature (a Prelude name?)"
- odd_name src_loc)
+tcInterfaceSigs :: [RenamedSig] -> TcM s [Id]
+
+tcInterfaceSigs [] = returnTc []
+
+tcInterfaceSigs (Sig name@(ValName uniq full_name) ty pragmas src_loc : sigs)
+ = tcAddSrcLoc src_loc (
+ tcPolyType ty `thenTc` \ sigma_ty ->
+ fixTc ( \ rec_id ->
+ tcGenPragmas (Just sigma_ty) rec_id pragmas
+ `thenNF_Tc` \ id_info ->
+ returnTc (mkImported uniq full_name sigma_ty id_info)
+ )) `thenTc` \ id ->
+ tcInterfaceSigs sigs `thenTc` \ sigs' ->
+ returnTc (id:sigs')
+
+
+tcInterfaceSigs (Sig odd_name _ _ src_loc : sigs)
+ = case odd_name of
+ WiredInVal _ | opt_CompilingPrelude
+ -> tcInterfaceSigs sigs
+ _ -> tcAddSrcLoc src_loc $
+ failTc (ifaceSigNameErr odd_name)
+
+ifaceSigNameErr name sty
+ = ppHang (ppStr "Bad name in an interface type signature (a Prelude name?)")
+ 4 (ppr sty name)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcInstDcls where
-import Bag(Bag)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(Binds, MonoBinds, Sig)
-import HsDecls(InstDecl, SpecialisedInstanceSig)
-import HsExpr(Expr)
-import HsPat(InPat, TypecheckedPat)
-import HsPragmas(InstancePragmas)
-import Id(Id)
-import IdInfo(SpecEnv)
-import Inst(Inst)
-import InstEnv(InstTemplate)
-import LIE(LIE)
-import Name(Name)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-data InstInfo = InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name]
-buildInstanceEnvs :: Bag InstInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv))
-mkInstanceRelatedIds :: E -> Bool -> _PackedString -> InstancePragmas Name -> a -> Class -> [TyVarTemplate] -> UniType -> [(Class, UniType)] -> [Sig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Id, [(Class, UniType)], [Id])
-processInstBinds :: E -> [TyVar] -> (Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Expr Id TypecheckedPat, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [TyVar] -> [Inst] -> [Id] -> MonoBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], MonoBinds Id TypecheckedPat)
-tcInstDecls1 :: E -> UniqFM Class -> UniqFM TyCon -> [InstDecl Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Bag InstInfo, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-tcInstDecls2 :: E -> Bag InstInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, Binds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-tcSpecInstSigs :: E -> UniqFM Class -> UniqFM TyCon -> Bag InstInfo -> [SpecialisedInstanceSig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Bag InstInfo)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcInstDecls]{Typechecking instance declarations}
#include "HsVersions.h"
module TcInstDcls (
- tcInstDecls1, tcInstDecls2,
- tcSpecInstSigs,
- buildInstanceEnvs, processInstBinds,
- mkInstanceRelatedIds,
- InstInfo(..)
+ tcInstDecls1,
+ tcInstDecls2,
+ processInstBinds
) where
-IMPORT_Trace -- ToDo:rm debugging
-import Outputable
-import Pretty
-import TcMonad -- typechecking monad machinery
-import TcMonadFns ( newDicts, newMethod, newLocalWithGivenTy,
- newClassOpLocals, copyTyVars,
- applyTcSubstAndCollectTyVars
- )
-import AbsSyn -- the stuff being typechecked
-import AbsPrel ( pAT_ERROR_ID )
-import AbsUniType
-import BackSubst ( applyTcSubstToBinds )
-import Bag ( emptyBag, unitBag, unionBags, bagToList )
-import CE ( lookupCE, CE(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import GenSpecEtc ( checkSigTyVars, SignatureInfo )
-import E ( mkE, getE_CE, getE_TCE, growE_LVE, tvOfE, LVE(..), E )
-import Errors ( dupInstErr, derivingWhenInstanceExistsErr,
- preludeInstanceErr, nonBoxedPrimCCallErr,
- specInstUnspecInstNotFoundErr,
- Error(..), UnifyErrContext(..)
- )
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import Id -- lots of things
-import IdInfo -- ditto
-import Inst ( Inst, InstOrigin(..) )
-import InstEnv
-import Maybes ( catMaybes, mkLookupFun, maybeToBool, Maybe(..) )
-import Name ( getTagFromClassOpName )
-import NameTypes ( fromPrelude )
-import PlainCore ( escErrorMsg )
-import LIE ( nullLIE, mkLIE, unMkLIE, plusLIE, LIE )
-import ListSetOps ( minusList )
-import TCE ( TCE(..), UniqFM )
-import TVE ( mkTVE, TVE(..) )
-import Spec ( specTy )
-import TcContext ( tcContext )
-import TcBinds ( tcSigs, doSpecPragma )
+import Ubiq
+
+import HsSyn ( InstDecl(..), FixityDecl, Sig(..),
+ SpecInstSig(..), HsBinds(..), Bind(..),
+ MonoBinds(..), GRHSsAndBinds, Match,
+ InPat(..), OutPat(..), HsExpr(..), HsLit(..),
+ Stmt, Qual, ArithSeqInfo, Fake,
+ PolyType(..), MonoType )
+import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..),
+ RenamedInstDecl(..), RenamedFixityDecl(..),
+ RenamedSig(..), RenamedSpecInstSig(..) )
+import TcHsSyn ( TcIdOcc(..), TcHsBinds(..),
+ TcMonoBinds(..), TcExpr(..),
+ mkHsTyLam, mkHsTyApp,
+ mkHsDictLam, mkHsDictApp )
+
+
+import TcMonad
+import GenSpecEtc ( checkSigTyVars, specTy )
+import Inst ( Inst, InstOrigin(..), InstanceMapper(..),
+ newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
+import TcBinds ( tcPragmaSigs )
+import TcDeriv ( tcDeriving )
+import TcEnv ( tcLookupClass, tcTyVarScope, newLocalIds )
import TcGRHSs ( tcGRHSsAndBinds )
+import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
+import TcKind ( TcKind, unifyKind )
import TcMatches ( tcMatchesFun )
-import TcMonoType ( tcInstanceType )
-import TcPragmas ( tcDictFunPragmas, tcGenPragmas )
+import TcMonoType ( tcContext, tcMonoTypeKind )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas )
+import TcType ( TcType(..), TcTyVar(..),
+ tcInstTyVar, tcInstType, tcInstTheta )
import Unify ( unifyTauTy )
-import Unique ( cCallableClassKey, cReturnableClassKey )
-import Util
+
+
+import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
+ concatBag, foldBag, bagToList )
+import CmdLineOpts ( opt_GlasgowExts, opt_CompilingPrelude,
+ opt_OmitDefaultInstanceMethods,
+ opt_SpecialiseOverloaded )
+import Class ( GenClass, GenClassOp,
+ isCcallishClass, getClassBigSig,
+ getClassOps, getClassOpLocalType )
+import CoreUtils ( escErrorMsg )
+import Id ( idType, isDefaultMethodId_maybe )
+import ListSetOps ( minusList )
+import Maybes ( maybeToBool, expectJust )
+import Name ( Name, getTagFromClassOpName )
+import Outputable
+import PrelInfo ( pAT_ERROR_ID )
+import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
+ pprParendType )
+import PprStyle
+import Pretty
+import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+import TyCon ( derivedFor )
+import Type ( GenType(..), ThetaType(..), mkTyVarTy,
+ splitSigmaTy, splitAppTy, isTyVarTy, matchTy,
+ getTyCon_maybe, maybeBoxedPrimType )
+import TyVar ( GenTyVar, tyVarListToSet )
+import TysWiredIn ( stringTy )
+import Unique ( Unique )
+import Util ( panic )
+
\end{code}
Typechecking instance declarations is done in two passes. The first
-pass, made by @tcInstDecls1@,
-collects information to be used in the second pass.
+pass, made by @tcInstDecls1@, collects information to be used in the
+second pass.
This pre-processed info includes the as-yet-unprocessed bindings
inside the instance declaration. These are type-checked in the second
all the instance and value decls. Indeed that's the reason we need
two passes over the instance decls.
- instance c => k (t tvs) where b
-
-\begin{code}
-data InstInfo
- = InstInfo
- Class -- Class, k
- [TyVarTemplate] -- Type variables, tvs
- UniType -- The type at which the class is being
- -- instantiated
- ThetaType -- inst_decl_theta: the original context from the
- -- instance declaration. It constrains (some of)
- -- the TyVarTemplates above
- ThetaType -- dfun_theta: the inst_decl_theta, plus one
- -- element for each superclass; the "Mark
- -- Jones optimisation"
- Id -- The dfun id
- [Id] -- Constant methods (either all or none)
- RenamedMonoBinds -- Bindings, b
- Bool -- True <=> local instance decl
- FAST_STRING -- Name of module where this instance was
- -- defined.
- SrcLoc -- Source location assoc'd with this instance's defn
- [RenamedSig] -- User pragmas recorded for generating specialised methods
-\end{code}
+Here is the overall algorithm.
+Assume that we have an instance declaration
-Here is the overall algorithm. Assume that
+ instance c => k (t tvs) where b
\begin{enumerate}
\item
\end{enumerate}
\begin{code}
-tcInstDecls1 :: E -> CE -> TCE -> [RenamedInstDecl] -> NF_TcM (Bag InstInfo)
-
-tcInstDecls1 e ce tce [] = returnNF_Tc emptyBag
-
-tcInstDecls1 e ce tce (inst_decl : rest)
- = tc_inst_1 inst_decl `thenNF_Tc` \ infos1 ->
- tcInstDecls1 e ce tce rest `thenNF_Tc` \ infos2 ->
- returnNF_Tc (infos1 `unionBags` infos2)
- where
- tc_inst_1 (InstDecl context class_name ty binds from_here modname imod uprags pragmas src_loc)
- =
- -- Prime error recovery and substitution pruning
- recoverTc emptyBag (
- addSrcLocTc src_loc (
-
- let
- clas = lookupCE ce class_name -- Renamer ensures this can't fail
-
- for_ccallable_or_creturnable
- = class_name == cCallableClass || class_name == cReturnableClass
- where
- cCallableClass = PreludeClass cCallableClassKey bottom
- cReturnableClass = PreludeClass cReturnableClassKey bottom
- bottom = panic "for_ccallable_etc"
-
- -- Make some new type variables, named as in the instance type
- ty_names = extractMonoTyNames (==) ty
- (tve,inst_tyvars,_) = mkTVE ty_names
- in
- -- Check the instance type, including its syntactic constraints
- babyTcMtoTcM (tcInstanceType ce tce tve from_here src_loc ty)
- `thenTc` \ inst_ty ->
-
- -- DEAL WITH THE INSTANCE CONTEXT
- babyTcMtoTcM (tcContext ce tce tve context) `thenTc` \ theta ->
-
- -- SOME BORING AND TURGID CHECKING:
- let
- inst_for_function_type = isFunType inst_ty
- -- sigh; it happens; must avoid tickling inst_tycon
-
- inst_tycon_maybe = getUniDataTyCon_maybe inst_ty
-
- inst_tycon = case inst_tycon_maybe of
- Just (xx,_,_) -> xx
- Nothing -> panic "tcInstDecls1:inst_tycon"
- in
- -------------------------------------------------------------
- -- It is illegal for a normal user's module to declare an
- -- instance for a Prelude-class/Prelude-type instance:
- checkTc (from_here -- really an inst decl in this module
- && fromPreludeCore clas -- prelude class
- && (inst_for_function_type -- prelude type
- || fromPreludeCore inst_tycon)
- && not (fromPrelude modname) -- we aren't compiling a Prelude mod
- )
- (preludeInstanceErr clas inst_ty src_loc) `thenTc_`
-
- -------------------------------------------------------------
- -- It is obviously illegal to have an explicit instance
- -- for something that we are also planning to `derive'.
- -- Note that an instance decl coming in from outside
- -- is probably just telling us about the derived instance
- -- (ToDo: actually check, if possible), so we mustn't flag
- -- it as an error.
- checkTc (from_here
- && not inst_for_function_type
- && clas `derivedFor` inst_tycon)
- (derivingWhenInstanceExistsErr clas inst_tycon) `thenTc_`
-
- -------------------------------------------------------------
- -- A user declaration of a _CCallable/_CReturnable instance
- -- must be for a "boxed primitive" type.
- getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
- checkTc (for_ccallable_or_creturnable
- && from_here -- instance defined here
- && not (sw_chkr CompilingPrelude) -- which allows anything
- && (inst_for_function_type || -- a *function*??? hah!
- not (maybeToBool (maybeBoxedPrimType inst_ty)))) -- naughty, naughty
- (nonBoxedPrimCCallErr clas inst_ty src_loc) `thenTc_`
-
- -- END OF TURGIDITY; back to real fun
- -------------------------------------------------------------
-
- if (not inst_for_function_type && clas `derivedFor` inst_tycon) then
- -- Don't use this InstDecl; tcDeriv will make the
- -- InstInfo to be used in later processing.
- returnTc emptyBag
-
- else
- -- Make the dfun id and constant-method ids
- mkInstanceRelatedIds e
- from_here modname pragmas src_loc
- clas inst_tyvars inst_ty theta uprags
- `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
-
- returnTc ( unitBag (
- InstInfo clas inst_tyvars inst_ty theta
- dfun_theta dfun_id const_meth_ids
- binds from_here modname src_loc uprags
- ))
- ))
-\end{code}
-
-
-Common bit of code shared with @tcDeriving@:
-\begin{code}
-mkInstanceRelatedIds e
- from_here modname inst_pragmas locn
- clas
- inst_tyvars inst_ty inst_decl_theta uprags
- = getUniqueTc `thenNF_Tc` \ uniq ->
- let
- (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
-
- super_class_theta = super_classes `zip` (repeat inst_ty)
-
-
- dfun_theta = case inst_decl_theta of
-
- [] -> [] -- If inst_decl_theta is empty, then we don't
- -- want to have any dict arguments, so that we can
- -- expose the constant methods.
-
- other -> inst_decl_theta ++ super_class_theta
- -- Otherwise we pass the superclass dictionaries to
- -- the dictionary function; the Mark Jones optimisation.
-
- dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
- in
- fixNF_Tc ( \ rec_dfun_id ->
- babyTcMtoNF_TcM (
- tcDictFunPragmas e dfun_ty rec_dfun_id inst_pragmas
- ) `thenNF_Tc` \ dfun_pragma_info ->
- let
- dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
- dfun_info = dfun_pragma_info `addInfo` dfun_specenv
- in
- returnNF_Tc (mkDictFunId uniq clas inst_ty dfun_ty from_here modname dfun_info)
- ) `thenNF_Tc` \ dfun_id ->
-
- -- Make the constant-method ids, if there are no type variables involved
- (if not (null inst_tyvars) -- ToDo: could also do this if theta is null...
- then
- returnNF_Tc []
- else
- let
- inline_mes = [ getTagFromClassOpName v | (InlineSig v _ _) <- uprags ]
-
- mk_const_meth op uniq
- = mkConstMethodId
- uniq
- clas op inst_ty
- meth_ty from_here modname info
- where
- is_elem = isIn "mkInstanceRelatedIds"
-
- info = if tag `is_elem` inline_mes
- then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
- else noIdInfo
-
- tenv = [(class_tyvar, inst_ty)]
- tag = getClassOpTag op
- op_ty = getClassOpLocalType op
- meth_ty = instantiateTy tenv op_ty
- -- If you move to a null-theta version, you need a
- -- mkForallTy inst_tyvars here
-
- mk_constm_w_info (op, u, (name, prags)) -- ToDo: chk name?
- = fixNF_Tc ( \ rec_constm_id ->
-
- babyTcMtoNF_TcM (tcGenPragmas e (Just meth_ty) rec_constm_id prags)
- `thenNF_Tc` \ id_info ->
-
- returnNF_Tc (mkConstMethodId u clas op inst_ty meth_ty
- from_here modname id_info)
- )
- where
- tenv = [(class_tyvar, inst_ty)]
- op_ty = getClassOpLocalType op
- meth_ty = instantiateTy tenv op_ty
-
- in
- getUniquesTc (length class_ops) `thenNF_Tc` \ constm_uniqs ->
- (case inst_pragmas of
- ConstantInstancePragma _ name_pragma_pairs ->
- mapNF_Tc mk_constm_w_info (zip3 class_ops constm_uniqs name_pragma_pairs)
-
- other_inst_pragmas ->
- returnNF_Tc (zipWith mk_const_meth class_ops constm_uniqs)
- )
- ) `thenNF_Tc` \ const_meth_ids ->
-
- returnTc (dfun_id, dfun_theta, const_meth_ids)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Converting instance info into suitable InstEnvs}
-%* *
-%************************************************************************
-
-\begin{code}
-buildInstanceEnvs :: Bag InstInfo
- -> TcM InstanceMapper
-
-buildInstanceEnvs info
- = let
- cmp :: InstInfo -> InstInfo -> TAG_
- (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `cmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
- = if c1 == c2 then EQ_ else if c1 < c2 then LT_ else GT_
-
- info_by_class = equivClasses cmp (bagToList info)
- in
- mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries ->
+tcInstDecls1 :: Bag RenamedInstDecl
+ -> [RenamedSpecInstSig]
+ -> FAST_STRING -- module name for deriving
+ -> GlobalNameMappers -- renamer fns for deriving
+ -> [RenamedFixityDecl] -- fixities for deriving
+ -> TcM s (Bag InstInfo,
+ RenamedHsBinds,
+ PprStyle -> Pretty)
+
+tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities
+ = -- Do the ordinary instance declarations
+ mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
+ `thenNF_Tc` \ inst_info_bags ->
let
- class_lookup_maybe_fn
- :: Class
- -> Maybe (ClassInstEnv, (ClassOp -> SpecEnv))
- class_lookup_fn
- :: InstanceMapper
-
- class_lookup_maybe_fn = mkLookupFun (==) inst_env_entries
-
- class_lookup_fn c
- = case class_lookup_maybe_fn c of
- Nothing -> (nullMEnv, \ o -> nullSpecEnv)
- Just xx -> xx
+ decl_inst_info = concatBag inst_info_bags
in
- returnTc class_lookup_fn
-\end{code}
+ -- Handle "derived" instances; note that we only do derivings
+ -- for things in this module; we ignore deriving decls from
+ -- interfaces! We pass fixities, because they may be used
+ -- in deriving Read and Show.
+ tcDeriving mod_name renamer_name_funs decl_inst_info fixities
+ `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
-\begin{code}
-buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
- -> TcM (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
-
-buildInstanceEnv inst_infos@(info_for_one@(InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : rest)
- = let
- ops = getClassOps clas
- no_of_ops = length ops
+ let
+ inst_info = deriv_inst_info `unionBags` decl_inst_info
in
- foldlTc addClassInstance
- (nullMEnv, nOfThem no_of_ops nullSpecEnv)
- inst_infos `thenTc` \ (class_inst_env, op_inst_envs) ->
+{- LATER
+ -- Handle specialise instance pragmas
+ tcSpecInstSigs inst_info specinst_sigs
+ `thenTc` \ spec_inst_info ->
+-}
let
- class_op_maybe_fn :: ClassOp -> Maybe SpecEnv
- class_op_fn :: ClassOp -> SpecEnv
-
- class_op_maybe_fn = mkLookupFun (==) (ops `zip` op_inst_envs)
- -- They compare by ClassOp tags
- class_op_fn op
- = case class_op_maybe_fn op of
- Nothing -> nullSpecEnv
- Just xx -> xx
+ spec_inst_info = emptyBag -- For now
+
+ full_inst_info = inst_info `unionBags` spec_inst_info
in
- returnTc (clas, (class_inst_env, class_op_fn))
+ returnTc (full_inst_info, deriv_binds, ddump_deriv)
+
+
+tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+
+tcInstDecl1 mod_name
+ (InstDecl class_name
+ poly_ty@(HsForAllTy tyvar_names context inst_ty)
+ binds
+ from_here inst_mod uprags pragmas src_loc)
+ = -- Prime error recovery, set source location
+ recoverNF_Tc (returnNF_Tc emptyBag) $
+ tcAddSrcLoc src_loc $
+
+ -- Look things up
+ tcLookupClass class_name `thenNF_Tc` \ (clas_kind, clas) ->
+
+ -- Typecheck the context and instance type
+ tcTyVarScope tyvar_names (\ tyvars ->
+ tcContext context `thenTc` \ theta ->
+ tcMonoTypeKind inst_ty `thenTc` \ (tau_kind, tau) ->
+ unifyKind clas_kind tau_kind `thenTc_`
+ returnTc (tyvars, theta, tau)
+ ) `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
+
+ -- Check for respectable instance type
+ scrutiniseInstanceType from_here clas inst_tau
+ `thenTc` \ (inst_tycon,arg_tys) ->
+
+ -- Deal with the case where we are deriving
+ -- and importing the same instance
+ if (not from_here && (clas `derivedFor` inst_tycon)
+ && all isTyVarTy arg_tys)
+ then
+ if mod_name == inst_mod then
+ -- Imported instance came from this module;
+ -- discard and derive fresh instance
+ returnTc emptyBag
+ else
+ -- Imported instance declared in another module;
+ -- report duplicate instance error
+ failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon)
+ else
+
+ -- Make the dfun id and constant-method ids
+ mkInstanceRelatedIds from_here inst_mod pragmas
+ clas inst_tyvars inst_tau inst_theta uprags
+ `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
+
+ returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
+ dfun_theta dfun_id const_meth_ids
+ binds from_here inst_mod src_loc uprags))
\end{code}
-\begin{code}
-addClassInstance
- :: (ClassInstEnv, [SpecEnv])
- -> InstInfo
- -> TcM (ClassInstEnv, [SpecEnv]) -- One SpecEnv for each class op
-
-addClassInstance
- (class_inst_env, op_spec_envs)
- (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta dfun_id const_meth_ids _ _ _ src_loc _)
- = getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
- -- We anly add specialised/overlapped instances
- -- if we are specialising the overloading
---
--- ToDo ... This causes getConstMethodId errors!
---
--- if is_plain_instance inst_ty || sw_chkr SpecialiseOverloaded
--- then
-
- -- Insert into the class_inst_env first
- checkMaybeErrTc (addClassInst clas class_inst_env inst_ty dfun_id inst_tyvars dfun_theta src_loc)
- dupInstErr `thenTc` \ class_inst_env' ->
- let
- -- Adding the classop instances can't fail if the class instance itself didn't
- op_spec_envs' = case const_meth_ids of
- [] -> op_spec_envs
- other -> zipWith add_const_meth op_spec_envs const_meth_ids
- in
- returnTc (class_inst_env', op_spec_envs')
-
--- else
--- -- Drop this specialised/overlapped instance
--- returnTc (class_inst_env, op_spec_envs)
-
- where
- add_const_meth spec_env meth_id
- = addOneToSpecEnv spec_env (SpecInfo (Just inst_ty:nothings) 1 meth_id)
- where
- (const_meth_tyvars,_) = splitForalls (getIdUniType meth_id)
- nothings = [Nothing | _ <- const_meth_tyvars]
- -- This only works if the constant method id only has its local polymorphism.
- -- If you want to have constant methods for
- -- instance Foo (a,b,c) where
- -- op x = ...
- -- then the constant method will be polymorphic in a,b,c, and
- -- the SpecInfo will need to be elaborated.
-
-\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-tcInstDecls2 :: E
- -> Bag InstInfo
- -> NF_TcM (LIE, TypecheckedBinds)
-
-tcInstDecls2 e inst_decls
- = let
- -- Get type variables free in environment. Sadly, there may be
- -- some, because of the dreaded monomorphism restriction
- free_tyvars = tvOfE e
- in
- tcInstDecls2_help e free_tyvars (bagToList inst_decls)
+tcInstDecls2 :: Bag InstInfo
+ -> NF_TcM s (LIE s, TcHsBinds s)
-tcInstDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
-
-tcInstDecls2_help e free_tyvars (inst_decl:inst_decls)
- = tcInstDecl2 e free_tyvars inst_decl `thenNF_Tc` \ (lie1, binds1) ->
- tcInstDecls2_help e free_tyvars inst_decls `thenNF_Tc` \ (lie2, binds2) ->
- returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
+tcInstDecls2 inst_decls
+ = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
+ where
+ combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
+ tc2 `thenNF_Tc` \ (lie2, binds2) ->
+ returnNF_Tc (lie1 `plusLIE` lie2,
+ binds1 `ThenBinds` binds2)
\end{code}
======= New documentation starts here (Sept 92) ==============
-The main purpose of @tcInstDecl2@ is to return a @Binds@ which defines
+The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
the dictionary function for this instance declaration. For example
\begin{verbatim}
instance Foo a => Foo [a] where
Dict [op1, op2]
\end{verbatim}
-HOWEVER, if the instance decl has no type variables, then it returns a
-bigger @Binds@ with declarations for each method. For example
+HOWEVER, if the instance decl has no context, then it returns a
+bigger @HsBinds@ with declarations for each method. For example
\begin{verbatim}
- instance Foo Int where
+ instance Foo [a] where
op1 x = ...
op2 y = ...
\end{verbatim}
might produce
\begin{verbatim}
- dfun.Foo.Int = Dict [Foo.op1.Int, Foo.op2.Int]
- Foo.op1.Int x = ...
- Foo.op2.Int y = ...
+ dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
+ const.Foo.op1.List a x = ...
+ const.Foo.op2.List a y = ...
\end{verbatim}
This group may be mutually recursive, because (for example) there may
be no method supplied for op2 in which case we'll get
\begin{verbatim}
- Foo.op2.Int = default.Foo.op2 dfun.Foo.Int
+ const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
\end{verbatim}
that is, the default method applied to the dictionary at this type.
-\begin{code}
-tcInstDecl2 :: E
- -> [TyVar] -- Free in the environment
- -> InstInfo
- -> NF_TcM (LIE, TypecheckedBinds)
-\end{code}
+What we actually produce in either case is:
-First comes the easy case of a non-local instance decl.
+ AbsBinds [a] [dfun_theta_dicts]
+ [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
+ { d = (sd1,sd2, ..., op1, op2, ...)
+ op1 = ...
+ op2 = ...
+ }
-\begin{code}
-tcInstDecl2 e free_tyvars (InstInfo _ _ _ _ _ _ _ _ False{-not this module-} _ _ _)
- = returnNF_Tc (nullLIE, EmptyBinds)
-\end{code}
+The "maybe" says that we only ask AbsBinds to make global constant methods
+if the dfun_theta is empty.
-Now the case of a general local instance. For an instance declaration, say,
+
+For an instance declaration, say,
instance (C1 a, C2 b) => C (T a b) where
...
is the ``Mark Jones optimisation''. The stuff before the "=>" here
is the @dfun_theta@ below.
+First comes the easy case of a non-local instance decl.
+
\begin{code}
-tcInstDecl2
- e free_tyvars
- (InstInfo clas template_tyvars inst_ty_tmpl inst_decl_theta dfun_theta
- dfun_id const_meth_ids monobinds True{-from here-} inst_mod locn uprags)
- = let
- origin = InstanceDeclOrigin locn
- in
- recoverTc (nullLIE, EmptyBinds) (
- addSrcLocTc locn (
- pruneSubstTc free_tyvars (
+tcInstDecl2 :: InstInfo
+ -> NF_TcM s (LIE s, TcHsBinds s)
+
+tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _)
+ = returnNF_Tc (emptyLIE, EmptyBinds)
+
+tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
+ inst_decl_theta dfun_theta
+ dfun_id const_meth_ids monobinds
+ True{-here-} inst_mod locn uprags)
+ = -- Prime error recovery
+ recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
+ tcAddSrcLoc locn $
-- Get the class signature
- let (class_tyvar,
- super_classes, sc_sel_ids,
- class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
- in
- -- Prime error recovery and substitution pruning. Instantiate
- -- dictionaries from the specified instance context. These
- -- dicts will be passed into the dictionary-construction
- -- function.
- copyTyVars template_tyvars `thenNF_Tc` \ (inst_env, inst_tyvars, inst_tyvar_tys) ->
+ mapNF_Tc tcInstTyVar inst_tyvars `thenNF_Tc` \ inst_tyvars' ->
let
- inst_ty = instantiateTy inst_env inst_ty_tmpl
+ tenv = inst_tyvars `zip` (map mkTyVarTy inst_tyvars')
- inst_decl_theta' = instantiateThetaTy inst_env inst_decl_theta
- dfun_theta' = instantiateThetaTy inst_env dfun_theta
- sc_theta' = super_classes `zip` (repeat inst_ty)
- in
- newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts' ->
- newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts' ->
- newDicts origin inst_decl_theta' `thenNF_Tc` \ inst_decl_dicts' ->
- let
- sc_dicts'_ids = map mkInstId sc_dicts'
- dfun_arg_dicts'_ids = map mkInstId dfun_arg_dicts'
+ (class_tyvar,
+ super_classes, sc_sel_ids,
+ class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
in
- -- Instantiate the dictionary being constructed
- -- and the dictionary-construction function
- newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ [this_dict] ->
+ tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' ->
+ tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
+ tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
let
- this_dict_id = mkInstId this_dict
- in
- -- Instantiate method variables
- listNF_Tc [ newMethodId sel_id inst_ty origin locn
- | sel_id <- op_sel_ids
- ] `thenNF_Tc` \ method_ids ->
- let
- method_insts = catMaybes (map isInstId_maybe method_ids)
- -- Extract Insts from those method ids which have them (most do)
- -- See notes on newMethodId
- in
- -- Collect available dictionaries
- let avail_insts = -- These insts are in scope; quite a few, eh?
- [this_dict] ++
- method_insts ++
- dfun_arg_dicts'
+ sc_theta' = super_classes `zip` (repeat inst_ty')
+ origin = InstanceDeclOrigin
+ mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
in
- getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
+ -- Create dictionary Ids from the specified instance contexts.
+ newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
+ newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
+ newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
+ newDicts origin [(clas,inst_ty')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+
+ -- Create method variables
+ mapAndUnzipNF_Tc mk_method op_sel_ids `thenNF_Tc` \ (meth_insts_s, meth_ids) ->
+
+ -- Collect available Insts
let
+ avail_insts -- These insts are in scope; quite a few, eh?
+ = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s)
+
mk_method_expr
- = if sw_chkr OmitDefaultInstanceMethods then
- makeInstanceDeclNoDefaultExpr origin clas method_ids defm_ids inst_mod inst_ty
+ = if opt_OmitDefaultInstanceMethods then
+ makeInstanceDeclNoDefaultExpr origin clas meth_ids defm_ids inst_mod inst_ty'
else
- makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty
+ makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty'
in
- processInstBinds e free_tyvars mk_method_expr
- inst_tyvars avail_insts method_ids monobinds
- `thenTc` \ (insts_needed, method_mbinds) ->
+ processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds
+ `thenTc` \ (insts_needed, method_mbinds) ->
let
-- Create the dict and method binds
dict_bind
- = VarMonoBind this_dict_id (Dictionary sc_dicts'_ids method_ids)
+ = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
dict_and_method_binds
= dict_bind `AndMonoBinds` method_mbinds
+
+ inst_tyvars_set' = tyVarListToSet inst_tyvars'
in
-- Check the overloading constraints of the methods and superclasses
- -- The global tyvars must be a fixed point of the substitution
- applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
- tcSimplifyAndCheck
- True -- Top level
- real_free_tyvars -- Global tyvars
- inst_tyvars -- Local tyvars
+ tcAddErrCtxt (bindSigCtxt meth_ids) (
+ tcSimplifyAndCheck
+ inst_tyvars_set' -- Local tyvars
avail_insts
- (sc_dicts' ++ insts_needed) -- Need to get defns for all these
- (BindSigCtxt method_ids)
- `thenTc` \ (const_insts, super_binds) ->
+ (sc_dicts `unionBags` insts_needed) -- Need to get defns for all these
+ ) `thenTc` \ (const_lie, super_binds) ->
-- Check that we *could* construct the superclass dictionaries,
-- even though we are *actually* going to pass the superclass dicts in;
-- the check ensures that the caller will never have a problem building
-- them.
+ tcAddErrCtxt superClassSigCtxt (
tcSimplifyAndCheck
- False -- Doesn't matter; more efficient this way
- real_free_tyvars -- Global tyvars
- inst_tyvars -- Local tyvars
- inst_decl_dicts' -- The instance dictionaries available
- sc_dicts' -- The superclass dicationaries reqd
- SuperClassSigCtxt
- `thenTc_`
+ inst_tyvars_set' -- Local tyvars
+ inst_decl_dicts -- The instance dictionaries available
+ sc_dicts -- The superclass dicationaries reqd
+ ) `thenTc_`
-- Ignore the result; we're only doing
-- this to make sure it can be done.
-- Now process any SPECIALIZE pragmas for the methods
let
spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
-
- get_const_method_id name
- = const_meth_ids !! ((getTagFromClassOpName name) - 1)
in
- tcSigs e [] spec_sigs `thenTc` \ sig_info ->
-
- mapAndUnzipTc (doSpecPragma e get_const_method_id) sig_info
- `thenTc` \ (spec_binds_s, spec_lie_s) ->
- let
- spec_lie = foldr plusLIE nullLIE spec_lie_s
- spec_binds = foldr AndMonoBinds EmptyMonoBinds spec_binds_s
-
+ tcPragmaSigs spec_sigs `thenTc` \ (_, spec_binds, spec_lie) ->
+ let
-- Complete the binding group, adding any spec_binds
- inst_binds
- = AbsBinds
- inst_tyvars
- dfun_arg_dicts'_ids
- ((this_dict_id,dfun_id) : (method_ids `zip` const_meth_ids))
+ inst_binds
+ = AbsBinds
+ inst_tyvars'
+ dfun_arg_dicts_ids
+ ((this_dict_id, RealId dfun_id)
+ : (meth_ids `zip` (map RealId const_meth_ids)))
-- const_meth_ids will often be empty
super_binds
(RecBind dict_and_method_binds)
-
+
`ThenBinds`
- SingleBind (NonRecBind spec_binds)
+ spec_binds
in
- -- Back-substitute
- applyTcSubstToBinds inst_binds `thenNF_Tc` \ final_inst_binds ->
-
- returnTc (mkLIE const_insts `plusLIE` spec_lie,
- final_inst_binds)
- )))
-\end{code}
-
-@mkMethodId@ manufactures an id for a local method.
-It's rather turgid stuff, because there are two cases:
-
- (a) For methods with no local polymorphism, we can make an Inst of the
- class-op selector function and a corresp InstId;
- which is good because then other methods which call
- this one will do so directly.
- (b) For methods with local polymorphism, we can't do this. For example,
-
- class Foo a where
- op :: (Num b) => a -> b -> a
-
- Here the type of the class-op-selector is
-
- forall a b. (Foo a, Num b) => a -> b -> a
-
- The locally defined method at (say) type Float will have type
-
- forall b. (Num b) => Float -> b -> Float
-
- and the one is not an instance of the other.
-
- So for these we just make a local (non-Inst) id with a suitable type.
-
-How disgusting.
-
-\begin{code}
-newMethodId sel_id inst_ty origin loc
- = let (sel_tyvars,sel_theta,sel_tau) = splitType (getIdUniType sel_id)
- (_:meth_theta) = sel_theta -- The local theta is all except the
- -- first element of the context
- in
- case sel_tyvars of
- -- Ah! a selector for a class op with no local polymorphism
- -- Build an Inst for this
- [clas_tyvar] -> newMethod origin sel_id [inst_ty] `thenNF_Tc` \ inst ->
- returnNF_Tc (mkInstId inst)
-
- -- Ho! a selector for a class op with local polymorphism.
- -- Just make a suitably typed local id for this
- (clas_tyvar:local_tyvars) ->
- let
- method_ty = instantiateTy [(clas_tyvar,inst_ty)]
- (mkSigmaTy local_tyvars meth_theta sel_tau)
- in
- getUniqueTc `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkUserLocal (getOccurrenceName sel_id) uniq method_ty loc)
+ returnTc (const_lie `plusLIE` spec_lie, inst_binds)
\end{code}
This function makes a default method which calls the global default method, at
\begin{code}
makeInstanceDeclDefaultMethodExpr
- :: InstOrigin
- -> Id
+ :: InstOrigin s
+ -> TcIdOcc s
-> [ClassOp]
-> [Id]
- -> UniType
+ -> TcType s
-> Int
- -> NF_TcM TypecheckedExpr
-
-makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty tag
- = let
- (tyvar_tmpls, local_theta, _) = splitType (getClassOpLocalType class_op)
- in
- copyTyVars tyvar_tmpls `thenNF_Tc` \ (inst_env, tyvars, tys) ->
- let
- inst_theta = instantiateThetaTy inst_env local_theta
- in
- newDicts origin inst_theta `thenNF_Tc` \ local_dict_insts ->
- let
- local_dicts = map mkInstId local_dict_insts
- in
+ -> NF_TcM s (TcExpr s)
+
+makeInstanceDeclDefaultMethodExpr origin this_dict class_ops defm_ids inst_ty tag
+ = specTy origin (getClassOpLocalType class_op)
+ `thenNF_Tc` \ (op_tyvars, op_lie, op_tau, op_dicts) ->
+
+ -- def_op_id = /\ op_tyvars -> \ op_dicts ->
+ -- defm_id inst_ty op_tyvars this_dict op_dicts
+
returnNF_Tc (
- mkTyLam tyvars (
- mkDictLam local_dicts (
- mkDictApp (mkTyApp (Var defm_id)
- (inst_ty : tys))
- (this_dict_id:local_dicts)))
- )
+ mkHsTyLam op_tyvars (
+ mkHsDictLam op_dicts (
+ mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id))
+ (inst_ty : map mkTyVarTy op_tyvars))
+ (this_dict : op_dicts)
+ )))
where
idx = tag - 1
class_op = class_ops !! idx
defm_id = defm_ids !! idx
-
makeInstanceDeclNoDefaultExpr
- :: InstOrigin
+ :: InstOrigin s
-> Class
- -> [Id]
+ -> [TcIdOcc s]
-> [Id]
-> FAST_STRING
- -> UniType
+ -> TcType s
-> Int
- -> NF_TcM TypecheckedExpr
-
-makeInstanceDeclNoDefaultExpr origin clas method_ids defm_ids inst_mod inst_ty tag
- = specTy origin (getIdUniType method_id) `thenNF_Tc` \ (tyvars, dicts, tau) ->
-
- (if not err_defm then
- pprTrace "Warning: "
- (ppCat [ppStr "Omitted default method for",
- ppr PprForUser clas_op, ppStr "in instance",
- ppPStr clas_name, pprParendUniType PprForUser inst_ty])
- else id) (
+ -> NF_TcM s (TcExpr s)
- returnNF_Tc (mkTyLam tyvars (
- mkDictLam (map mkInstId dicts) (
- App (mkTyApp (Var pAT_ERROR_ID) [tau])
- (Lit (StringLit (_PK_ error_msg))))))
- )
+makeInstanceDeclNoDefaultExpr origin clas method_occs defm_ids inst_mod inst_ty tag
+ = let
+ (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType method_id)
+ in
+ 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 pAT_ERROR_ID)) [op_tau])
+ (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
where
- idx = tag - 1
- clas_op = (getClassOps clas) !! idx
- method_id = method_ids !! idx
- defm_id = defm_ids !! idx
+ idx = tag - 1
+ method_occ = method_occs !! idx
+ clas_op = (getClassOps clas) !! idx
+ defm_id = defm_ids !! idx
- Just (_, _, err_defm) = isDefaultMethodId_maybe defm_id
+ TcId method_id = method_occ
+ Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
error_msg = "%E" -- => No explicit method for \"
++ escErrorMsg error_str
%* *
%************************************************************************
-@processInstBinds@ returns a @MonoBinds@ which binds
+@processInstBinds@ returns a @MonoBinds@ which binds
all the method ids (which are passed in). It is used
- - both for instance decls,
+ - both for instance decls,
- and to compile the default-method declarations in a class decl.
-Any method ids which don't have a binding have a suitable default
-binding created for them. The actual right-hand side used is
+Any method ids which don't have a binding have a suitable default
+binding created for them. The actual right-hand side used is
created using a function which is passed in, because the right thing to
do differs between instance and class decls.
\begin{code}
processInstBinds
- :: E
- -> [TyVar] -- Free in envt
-
- -> (Int -> NF_TcM TypecheckedExpr) -- Function to make
- -- default method
-
- -> [TyVar] -- Tyvars for this instance decl
-
- -> [Inst] -- available Insts
-
- -> [Id] -- Local method ids
- -- (instance tyvars are free
- -- in their types),
- -- in tag order
+ :: (Int -> NF_TcM s (TcExpr s)) -- Function to make default method
+ -> [TcTyVar s] -- Tyvars for this instance decl
+ -> LIE s -- available Insts
+ -> [TcIdOcc s] -- Local method ids in tag order
+ -- (instance tyvars are free in their types)
-> RenamedMonoBinds
+ -> TcM s (LIE s, -- These are required
+ TcMonoBinds s)
- -> TcM ([Inst], -- These are required
- TypecheckedMonoBinds)
-
-processInstBinds e free_tyvars mk_method_expr inst_tyvars
- avail_insts method_ids monobinds
- =
+processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds
+ =
-- Process the explicitly-given method bindings
- processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids monobinds
- `thenTc` (\ (tags, insts_needed_in_methods, method_binds) ->
+ processInstBinds1 inst_tyvars avail_insts method_ids monobinds
+ `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
-- Find the methods not handled, and make default method bindings for them.
- let unmentioned_tags = [1.. length method_ids] `minusList` tags
+ let
+ unmentioned_tags = [1.. length method_ids] `minusList` tags
in
- makeDefaultMethods mk_method_expr unmentioned_tags method_ids
- `thenNF_Tc` (\ default_monobinds ->
+ mapNF_Tc mk_default_method unmentioned_tags
+ `thenNF_Tc` \ default_bind_list ->
- returnTc (insts_needed_in_methods,
- method_binds `AndMonoBinds` default_monobinds)
- ))
+ returnTc (insts_needed_in_methods,
+ foldr AndMonoBinds method_binds default_bind_list)
+ where
+ -- From a tag construct us the passed-in function to construct
+ -- the binding for the default method
+ mk_default_method tag = mk_default_method_rhs tag `thenNF_Tc` \ rhs ->
+ returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs)
\end{code}
\begin{code}
processInstBinds1
- :: E
- -> [TyVar] -- Global free tyvars
- -> [TyVar] -- Tyvars for this instance decl
- -> [Inst] -- available Insts
- -> [Id] -- Local method ids (instance tyvars are free),
- -- in tag order
- -> RenamedMonoBinds
- -> TcM ([Int], -- Class-op tags accounted for
- [Inst], -- These are required
- TypecheckedMonoBinds)
-
-processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids EmptyMonoBinds
- = returnTc ([], [], EmptyMonoBinds)
-
-processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
- = processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb1
+ :: [TcTyVar s] -- Tyvars for this instance decl
+ -> LIE s -- available Insts
+ -> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free),
+ -> RenamedMonoBinds
+ -> TcM s ([Int], -- Class-op tags accounted for
+ LIE s, -- These are required
+ TcMonoBinds s)
+
+processInstBinds1 inst_tyvars avail_insts method_ids EmptyMonoBinds
+ = returnTc ([], emptyLIE, EmptyMonoBinds)
+
+processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
+ = processInstBinds1 inst_tyvars avail_insts method_ids mb1
`thenTc` \ (op_tags1,dicts1,method_binds1) ->
- processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb2
+ processInstBinds1 inst_tyvars avail_insts method_ids mb2
`thenTc` \ (op_tags2,dicts2,method_binds2) ->
returnTc (op_tags1 ++ op_tags2,
- dicts1 ++ dicts2,
+ dicts1 `unionBags` dicts2,
AndMonoBinds method_binds1 method_binds2)
\end{code}
\begin{code}
-processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mbind
- =
+processInstBinds1 inst_tyvars avail_insts method_ids mbind
+ =
-- Find what class op is being defined here. The complication is
-- that we could have a PatMonoBind or a FunMonoBind. If the
-- former, it should only bind a single variable, or else we're in
(op,locn) = case mbind of
FunMonoBind op _ locn -> (op, locn)
PatMonoBind (VarPatIn op) _ locn -> (op, locn)
-
- origin = InstanceDeclOrigin locn
+
+ occ = getOccurrenceName op
+ origin = InstanceDeclOrigin
in
- addSrcLocTc locn (
+ tcAddSrcLoc locn $
-- Make a method id for the method
let tag = getTagFromClassOpName op
- method_id = method_ids !! (tag-1)
- method_ty = getIdUniType method_id
+ method_id = method_ids !! (tag-1)
+
+ TcId method_bndr = method_id
+ method_ty = idType method_bndr
+ (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
in
- specTy origin method_ty `thenNF_Tc` \ (method_tyvars, method_dicts, method_tau) ->
+ newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
- -- Build the result
- case (method_tyvars, method_dicts) of
+ case (method_tyvars, method_dict_ids) of
([],[]) -> -- The simple case; no local polymorphism or overloading in the method
-- Type check the method itself
- tcMethodBind e method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
+ tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
-- Make sure that the instance tyvars havn't been
-- unified with each other or with the method tyvars.
- -- The global tyvars must be a fixed point of the substitution
- applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
- checkSigTyVars real_free_tyvars inst_tyvars method_tau method_tau
- (MethodSigCtxt op method_tau) `thenTc_`
-
- returnTc ([tag], unMkLIE lieIop, mbind')
+ tcSetErrCtxt (methodSigCtxt op method_tau) (
+ checkSigTyVars inst_tyvars method_tau method_tau
+ ) `thenTc_`
+ returnTc ([tag], lieIop, mbind')
other -> -- It's a locally-polymorphic and/or overloaded method; UGH!
- -- Make a new id for (a) the local, non-overloaded method
- -- and (b) the locally-overloaded method
- -- The latter is needed just so we can return an AbsBinds wrapped
- -- up inside a MonoBinds.
- newLocalWithGivenTy op method_tau `thenNF_Tc` \ local_meth_id ->
- newLocalWithGivenTy op method_ty `thenNF_Tc` \ copy_meth_id ->
+ -- Make a new id for (a) the local, non-overloaded method
+ -- and (b) the locally-overloaded method
+ -- The latter is needed just so we can return an AbsBinds wrapped
+ -- up inside a MonoBinds.
+ newLocalIds [occ,occ] [method_tau,method_ty] `thenNF_Tc` \ new_ids ->
+ let
+ [local_id, copy_id] = map TcId new_ids
+ inst_method_tyvars = inst_tyvars ++ method_tyvars
+ in
-- Typecheck the method
- tcMethodBind e local_meth_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
+ tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
-- Make sure that the instance tyvars haven't been
-- unified with each other or with the method tyvars.
- -- The global tyvars must be a fixed point of the substitution
- applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
- checkSigTyVars real_free_tyvars (method_tyvars ++ inst_tyvars) method_tau method_tau
- (MethodSigCtxt op method_tau) `thenTc_`
+ tcAddErrCtxt (methodSigCtxt op method_tau) (
+ checkSigTyVars inst_method_tyvars method_tau method_tau
+ ) `thenTc_`
-- Check the overloading part of the signature.
-- Simplify everything fully, even though some
--
-- Here we must simplify constraints on "a" to catch all
-- the Bar-ish things.
- tcSimplifyAndCheck
- False -- Not top level
- real_free_tyvars
- (inst_tyvars ++ method_tyvars)
- (method_dicts ++ avail_insts)
- (unMkLIE lieIop)
- (MethodSigCtxt op method_ty) `thenTc` \ (f_dicts, dict_binds) ->
+ tcAddErrCtxt (methodSigCtxt op method_ty) (
+ tcSimplifyAndCheck
+ (tyVarListToSet inst_method_tyvars)
+ (method_dicts `plusLIE` avail_insts)
+ lieIop
+ ) `thenTc` \ (f_dicts, dict_binds) ->
returnTc ([tag],
f_dicts,
VarMonoBind method_id
- (Let
+ (HsLet
(AbsBinds
method_tyvars
- (map mkInstId method_dicts)
- [(local_meth_id, copy_meth_id)]
+ method_dict_ids
+ [(local_id, copy_id)]
dict_binds
(NonRecBind mbind'))
- (Var copy_meth_id)))
- )
+ (HsVar copy_id)))
\end{code}
\begin{code}
-tcMethodBind :: E -> Id -> UniType -> RenamedMonoBinds
- -> TcM (TypecheckedMonoBinds, LIE)
+tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
+ -> TcM s (TcMonoBinds s, LIE s)
-tcMethodBind e meth_id meth_ty (FunMonoBind name matches locn)
- = addSrcLocTc locn (
- tcMatchesFun e name meth_ty matches `thenTc` \ (rhs', lie) ->
+tcMethodBind meth_id meth_ty (FunMonoBind name matches locn)
+ = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
returnTc (FunMonoBind meth_id rhs' locn, lie)
- )
-tcMethodBind e meth_id meth_ty (PatMonoBind pat grhss_and_binds locn)
+tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
-- pat is sure to be a (VarPatIn op)
- = addSrcLocTc locn (
- tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
- unifyTauTy meth_ty rhs_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_`
+ = tcAddErrCtxt (patMonoBindsCtxt pbind) $
+ tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
+ unifyTauTy meth_ty rhs_ty `thenTc_`
returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
- )
\end{code}
-Creates bindings for the default methods, being the application of the
-appropriate global default method to the type of this instance decl.
-
-\begin{code}
-makeDefaultMethods
- :: (Int -> NF_TcM TypecheckedExpr) -- Function to make
- -- default method
- -> [Int] -- Tags for methods required
- -> [Id] -- Method names to bind, in tag order
- -> NF_TcM TypecheckedMonoBinds
-
-
-makeDefaultMethods mk_method_expr [] method_ids
- = returnNF_Tc EmptyMonoBinds
-
-makeDefaultMethods mk_method_expr (tag:tags) method_ids
- = mk_method_expr tag `thenNF_Tc` \ rhs ->
- makeDefaultMethods mk_method_expr tags method_ids `thenNF_Tc` \ meth_binds ->
-
- returnNF_Tc ((VarMonoBind method_id rhs) `AndMonoBinds` meth_binds)
- where
- method_id = method_ids !! (tag-1)
-\end{code}
-
%************************************************************************
%* *
\subsection{Type-checking specialise instance pragmas}
%************************************************************************
\begin{code}
+{- LATER
tcSpecInstSigs :: E -> CE -> TCE
- -> Bag InstInfo -- inst decls seen (declared and derived)
- -> [RenamedSpecialisedInstanceSig] -- specialise instance upragmas
- -> TcM (Bag InstInfo) -- new, overlapped, inst decls
+ -> Bag InstInfo -- inst decls seen (declared and derived)
+ -> [RenamedSpecInstSig] -- specialise instance upragmas
+ -> TcM (Bag InstInfo) -- new, overlapped, inst decls
tcSpecInstSigs e ce tce inst_infos []
= returnTc emptyBag
= returnNF_Tc emptyBag
tc_inst_spec_sigs inst_mapper (sig:sigs)
= tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig ->
- tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
- returnNF_Tc (info_sig `unionBags` info_sigs)
+ tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs ->
+ returnNF_Tc (info_sig `unionBags` info_sigs)
tcSpecInstSig :: E -> CE -> TCE
-> Bag InstInfo
-> InstanceMapper
- -> RenamedSpecialisedInstanceSig
+ -> RenamedSpecInstSig
-> NF_TcM (Bag InstInfo)
-tcSpecInstSig e ce tce inst_infos inst_mapper (InstSpecSig class_name ty src_loc)
+tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
= recoverTc emptyBag (
- addSrcLocTc src_loc (
+ tcAddSrcLoc src_loc (
let
clas = lookupCE ce class_name -- Renamer ensures this can't fail
babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
`thenTc` \ inst_ty ->
let
- maybe_tycon = case getUniDataTyCon_maybe inst_ty of
- Just (tc,_,_) -> Just tc
- Nothing -> Nothing
+ maybe_tycon = case maybeDataTyCon inst_ty of
+ Just (tc,_,_) -> Just tc
+ Nothing -> Nothing
- maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
+ maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
in
-- Check that we have a local instance declaration to specialise
checkMaybeTc maybe_unspec_inst
copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
let
Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
- _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
+ _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
subst = case matchTy unspec_inst_ty inst_ty of
Just subst -> subst
Nothing -> panic "tcSpecInstSig:matchTy"
subst_theta = instantiateThetaTy subst unspec_theta
- subst_tv_theta = instantiateThetaTy tv_e subst_theta
+ subst_tv_theta = instantiateThetaTy tv_e subst_theta
mk_spec_origin clas ty
- = InstanceSpecOrigin inst_mapper clas ty src_loc
+ = InstanceSpecOrigin inst_mapper clas ty src_loc
in
tcSimplifyThetas mk_spec_origin subst_tv_theta
`thenTc` \ simpl_tv_theta ->
(ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
if null simpl_theta then ppNil else ppStr "=>",
ppr PprDebug clas,
- pprParendUniType PprDebug inst_ty],
+ pprParendType PprDebug inst_ty],
ppCat [ppStr " derived from:",
if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
if null unspec_theta then ppNil else ppStr "=>",
ppr PprDebug clas,
- pprParendUniType PprDebug unspec_inst_ty]])
+ pprParendType PprDebug unspec_inst_ty]])
else id) (
returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
- dfun_theta dfun_id const_meth_ids
- binds True{-from here-} mod src_loc uprag))
+ dfun_theta dfun_id const_meth_ids
+ binds True{-from here-} mod src_loc uprag))
)))
where
match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
= from_here && clas == inst_clas &&
- match_ty inst_ty && is_plain_instance inst_ty
+ match_ty inst_ty && is_plain_instance inst_ty
match_inst_ty = case maybe_tycon of
Just tycon -> match_tycon tycon
Nothing -> match_fun
- match_tycon tycon inst_ty = case (getUniDataTyCon_maybe inst_ty) of
+ match_tycon tycon inst_ty = case (maybeDataTyCon inst_ty) of
Just (inst_tc,_,_) -> tycon == inst_tc
Nothing -> False
is_plain_instance inst_ty
- = case (getUniDataTyCon_maybe inst_ty) of
+ = case (maybeDataTyCon inst_ty) of
Just (_,tys,_) -> all isTyVarTemplateTy tys
Nothing -> case maybeUnpackFunTy inst_ty of
Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
Nothing -> error "TcInstDecls:is_plain_instance"
+-}
+\end{code}
+
+
+Checking for a decent instance type
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+@scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
+it must normally look like: @instance Foo (Tycon a b c ...) ...@
+
+The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
+flag is on, or (2)~the instance is imported (they must have been
+compiled elsewhere). In these cases, we let them go through anyway.
+
+We can also have instances for functions: @instance Foo (a -> b) ...@.
+
+\begin{code}
+scrutiniseInstanceType from_here clas inst_tau
+ -- TYCON CHECK
+ | not (maybeToBool inst_tycon_maybe)
+ = failTc (instTypeErr inst_tau)
+
+ -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
+ | from_here
+ = returnTc (inst_tycon,arg_tys)
+
+ -- TYVARS CHECK
+ | not (all isTyVarTy arg_tys ||
+ not from_here ||
+ opt_GlasgowExts)
+ = failTc (instTypeErr inst_tau)
+
+ -- DERIVING CHECK
+ -- It is obviously illegal to have an explicit instance
+ -- for something that we are also planning to `derive'
+ -- Though we can have an explicit instance which is more
+ -- specific than the derived instance
+ | clas `derivedFor` inst_tycon
+ && all isTyVarTy arg_tys
+ = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
+
+ | -- CCALL CHECK
+ -- 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)
+ = failTc (nonBoxedPrimCCallErr clas inst_tau)
+
+ | otherwise
+ = returnTc (inst_tycon,arg_tys)
+
+ where
+ (possible_tycon, arg_tys) = splitAppTy inst_tau
+ inst_tycon_maybe = getTyCon_maybe possible_tycon
+ inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
+\end{code}
+
+\begin{code}
+
+instTypeErr ty sty
+ = case ty of
+ SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
+ TyVarTy tv -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
+ other -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
+ where
+ rest_of_msg = ppStr "' cannot be used as an instance type."
+
+derivingWhenInstanceExistsErr clas tycon sty
+ = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
+ 4 (ppStr "when an explicit instance exists")
+
+derivingWhenInstanceImportedErr inst_mod clas tycon sty
+ = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
+ 4 (ppBesides [ppStr "when an instance declared in module `", ppPStr inst_mod, ppStr "' has been imported"])
+
+nonBoxedPrimCCallErr clas inst_ty sty
+ = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
+ 4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
+ ppr sty inst_ty, ppStr "'"])
+
+omitDefaultMethodWarn clas_op clas_name inst_ty sty
+ = ppCat [ppStr "Warning: Omitted default method for",
+ ppr sty clas_op, ppStr "in instance",
+ ppPStr clas_name, pprParendType sty inst_ty]
+
+
+patMonoBindsCtxt pbind sty
+ = ppHang (ppStr "In a pattern binding:")
+ 4 (ppr sty pbind)
+
+methodSigCtxt name ty sty
+ = ppHang (ppBesides [ppStr "When matching the definition of class method `",
+ ppr sty name, ppStr "' to its signature :" ])
+ 4 (ppr sty ty)
+
+bindSigCtxt method_ids sty
+ = ppHang (ppStr "When checking type signatures for: ")
+ 4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
+
+superClassSigCtxt sty
+ = ppStr "When checking superclass constraints on instance declaration"
+
\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[TcInstUtil]{Utilities for typechecking instance declarations}
+
+The bits common to TcInstDcls and TcDeriv.
+
+\begin{code}
+#include "HsVersions.h"
+
+module TcInstUtil (
+ InstInfo(..),
+ mkInstanceRelatedIds,
+ buildInstanceEnvs
+ ) where
+
+import Ubiq
+
+import HsSyn ( MonoBinds, Fake, InPat, Sig )
+import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
+ RenamedInstancePragmas(..) )
+
+import TcMonad
+import Inst ( InstanceMapper(..) )
+
+import Bag ( bagToList )
+import Class ( GenClass, GenClassOp, ClassInstEnv(..),
+ getClassBigSig, getClassOps, getClassOpLocalType )
+import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
+import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
+import MatchEnv ( nullMEnv, insertMEnv )
+import Maybes ( MaybeErr(..), mkLookupFunDef )
+import PprType ( GenClass, GenType, GenTyVar )
+import Pretty
+import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
+import SrcLoc ( SrcLoc )
+import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTy,
+ splitForAllTy, instantiateTy, matchTy, ThetaType(..) )
+import TyVar ( GenTyVar )
+import Unique ( Unique )
+import Util ( equivClasses, zipWithEqual, panic )
+
+
+import IdInfo ( noIdInfo )
+--import TcPragmas ( tcDictFunPragmas, tcGenPragmas )
+\end{code}
+
+ instance c => k (t tvs) where b
+
+\begin{code}
+data InstInfo
+ = InstInfo
+ Class -- Class, k
+ [TyVar] -- Type variables, tvs
+ Type -- The type at which the class is being instantiated
+ ThetaType -- inst_decl_theta: the original context, c, from the
+ -- instance declaration. It constrains (some of)
+ -- the TyVars above
+ ThetaType -- dfun_theta: the inst_decl_theta, plus one
+ -- element for each superclass; the "Mark
+ -- Jones optimisation"
+ Id -- The dfun id
+ [Id] -- Constant methods (either all or none)
+ RenamedMonoBinds -- Bindings, b
+ Bool -- True <=> local instance decl
+ FAST_STRING -- Name of module where this instance was
+ -- defined.
+ SrcLoc -- Source location assoc'd with this instance's defn
+ [RenamedSig] -- User pragmas recorded for generating specialised instances
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Creating instance related Ids}
+%* *
+%************************************************************************
+
+\begin{code}
+mkInstanceRelatedIds :: Bool -> FAST_STRING
+ -> RenamedInstancePragmas
+ -> Class
+ -> [TyVar]
+ -> Type
+ -> ThetaType
+ -> [RenamedSig]
+ -> TcM s (Id, ThetaType, [Id])
+
+mkInstanceRelatedIds from_here inst_mod inst_pragmas
+ clas inst_tyvars inst_ty inst_decl_theta uprags
+ = -- MAKE THE DFUN ID
+ let
+ dfun_theta = case inst_decl_theta of
+ [] -> [] -- If inst_decl_theta is empty, then we don't
+ -- want to have any dict arguments, so that we can
+ -- expose the constant methods.
+
+ other -> inst_decl_theta ++ super_class_theta
+ -- Otherwise we pass the superclass dictionaries to
+ -- the dictionary function; the Mark Jones optimisation.
+
+ dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
+ in
+ tcGetUnique `thenNF_Tc` \ dfun_uniq ->
+ fixTc ( \ rec_dfun_id ->
+
+{- LATER
+ tcDictFunPragmas dfun_ty rec_dfun_id inst_pragmas
+ `thenNF_Tc` \ dfun_pragma_info ->
+ let
+ dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
+ dfun_id_info = dfun_pragma_info `addInfo` dfun_specenv
+ in
+-}
+ let dfun_id_info = noIdInfo in -- For now
+
+ returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here inst_mod dfun_id_info)
+ ) `thenTc` \ dfun_id ->
+
+ -- MAKE THE CONSTANT-METHOD IDS
+ -- if there are no type variables involved
+ (if not (null inst_decl_theta)
+ then
+ returnTc []
+ else
+ mapTc mk_const_meth_id class_ops
+ ) `thenTc` \ const_meth_ids ->
+
+ returnTc (dfun_id, dfun_theta, const_meth_ids)
+ where
+ (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
+ tenv = [(class_tyvar, inst_ty)]
+
+ super_class_theta = super_classes `zip` (repeat inst_ty)
+
+ mk_const_meth_id op
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ fixTc (\ rec_const_meth_id ->
+
+{- LATER
+ -- Figure out the IdInfo from the pragmas
+ (case assocMaybe opname_prag_pairs (getName op) of
+ Nothing -> returnTc inline_info
+ Just prag -> tcGenPragmas (Just meth_ty) rec_const_meth_id prag
+ ) `thenNF_Tc` \ id_info ->
+-}
+ let id_info = noIdInfo -- For now
+ in
+ returnTc (mkConstMethodId uniq clas op inst_ty meth_ty
+ from_here inst_mod id_info)
+ )
+ where
+ op_ty = getClassOpLocalType op
+ meth_ty = mkForAllTys inst_tyvars (instantiateTy tenv op_ty)
+{- LATER
+ inline_me = isIn "mkInstanceRelatedIds" op ops_to_inline
+ inline_info = if inline_me
+ then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
+ else noIdInfo
+
+ opname_prag_pairs = case inst_pragmas of
+ ConstantInstancePragma _ name_prag_pairs -> name_prag_pairs
+ other_inst_pragmas -> []
+
+ ops_to_inline = [op | (InlineSig op _) <- uprags]
+-}
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Converting instance info into suitable InstEnvs}
+%* *
+%************************************************************************
+
+\begin{code}
+buildInstanceEnvs :: Bag InstInfo
+ -> TcM s InstanceMapper
+
+buildInstanceEnvs info
+ = let
+ icmp :: InstInfo -> InstInfo -> TAG_
+ (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
+ = c1 `cmp` c2
+
+ info_by_class = equivClasses icmp (bagToList info)
+ in
+ mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries ->
+ let
+ class_lookup_fn = mkLookupFunDef (==) inst_env_entries
+ (nullMEnv, \ o -> nullSpecEnv)
+ in
+ returnTc class_lookup_fn
+\end{code}
+
+\begin{code}
+buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
+ -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
+
+buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
+ = foldlTc addClassInstance
+ (nullMEnv, [(op, nullSpecEnv) | op <- getClassOps clas])
+ inst_infos
+ `thenTc` \ (class_inst_env, op_inst_envs) ->
+ returnTc (clas, (class_inst_env,
+ mkLookupFunDef (==) op_inst_envs
+ (panic "buildInstanceEnv")))
+\end{code}
+
+@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
+based on information from a single instance declaration. It complains
+about any overlap with an existing instance.
+
+\begin{code}
+addClassInstance
+ :: (ClassInstEnv, [(ClassOp,SpecEnv)])
+ -> InstInfo
+ -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
+
+addClassInstance
+ (class_inst_env, op_spec_envs)
+ (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
+ dfun_id const_meth_ids _ _ _ src_loc _)
+ =
+
+-- We only add specialised/overlapped instances
+-- if we are specialising the overloading
+-- ToDo ... This causes getConstMethodId errors!
+--
+-- if not (is_plain_instance inst_ty) && not opt_SpecialiseOverloaded
+-- then
+-- -- Drop this specialised/overlapped instance
+-- returnTc (class_inst_env, op_spec_envs)
+-- else
+
+ -- Add the instance to the class's instance environment
+ case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
+ Failed (ty', dfun_id') -> failTc (dupInstErr clas (inst_ty, src_loc)
+ (ty', getSrcLoc dfun_id'));
+ Succeeded class_inst_env' ->
+
+ -- If there are any constant methods, then add them to
+ -- the SpecEnv of each class op (ie selector)
+ --
+ -- Example. class Foo a where { op :: Baz b => a -> b }
+ -- instance Foo (p,q) where { op (x,y) = ... }
+ --
+ -- The constant method from the instance decl will be:
+ -- op_Pair :: forall p q b. Baz b => (p,q) -> b
+ --
+ -- What we put in op's SpecEnv is
+ -- (p,q) b |--> (\d::Foo (p,q) -> op_Pair p q b)
+ --
+ -- Here, [p,q] are the inst_tyvars, and d is a dict whose only
+ -- purpose is to cancel with the dict to which op is applied.
+ --
+ -- NOTE THAT this correctly deals with the case where there are
+ -- constant methods even though there are type variables in the
+ -- instance declaration.
+
+ tcGetUnique `thenNF_Tc` \ uniq ->
+ let
+ dict = mkSysLocal SLIT("dict_tpl") uniq (mkDictTy clas inst_ty) src_loc
+ -- Slightly disgusting, but it's only a placeholder for
+ -- a dictionary to be chucked away.
+
+ op_spec_envs' | null const_meth_ids = op_spec_envs
+ | otherwise = zipWithEqual add_const_meth op_spec_envs const_meth_ids
+
+ add_const_meth (op,spec_env) meth_id
+ = (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of
+ Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
+ Succeeded spec_env' -> spec_env' )
+ where
+ (local_tyvars, _) = splitForAllTy (getClassOpLocalType op)
+ local_tyvar_tys = map mkTyVarTy local_tyvars
+ rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id)
+ (map mkTyVarTy inst_tyvars))
+ local_tyvar_tys)
+ in
+ returnTc (class_inst_env', op_spec_envs')
+ }
+\end{code}
+
+\begin{code}
+dupInstErr clas info1@(ty1, locn1) info2@(ty2, locn2) sty
+ -- Overlapping/duplicate instances for given class; msg could be more glamourous
+ = ppHang (ppBesides [ppStr "Duplicate/overlapping instances: class `", ppr sty clas, ppStr "'"])
+ 4 (showOverlap sty info1 info2)
+
+showOverlap sty (ty1,loc1) (ty2,loc2)
+ = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
+ ppBesides [ppStr "at ", ppr sty loc1],
+ ppBesides [ppStr "and ", ppr sty loc2]]
+\end{code}
--- /dev/null
+\begin{code}
+module TcKind (
+
+ Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind,
+ isSubKindOf, -- Kind -> Kind -> Bool
+ resultKind, -- Kind -> Kind
+
+ TcKind, mkTcTypeKind, mkTcArrowKind, mkTcVarKind,
+ newKindVar, -- NF_TcM s (TcKind s)
+ newKindVars, -- Int -> NF_TcM s [TcKind s]
+ unifyKind, -- TcKind s -> TcKind s -> TcM s ()
+
+ kindToTcKind, -- Kind -> TcKind s
+ tcKindToKind -- TcKind s -> NF_TcM s Kind
+ ) where
+
+import Kind
+import TcMonad
+
+import Ubiq
+import Unique ( Unique, pprUnique10 )
+import Pretty
+\end{code}
+
+
+\begin{code}
+data TcKind s -- Used for kind inference
+ = TcTypeKind
+ | TcArrowKind (TcKind s) (TcKind s)
+ | TcVarKind Unique (MutableVar s (Maybe (TcKind s)))
+
+mkTcTypeKind = TcTypeKind
+mkTcArrowKind = TcArrowKind
+mkTcVarKind = TcVarKind
+
+newKindVar :: NF_TcM s (TcKind s)
+newKindVar = tcGetUnique `thenNF_Tc` \ uniq ->
+ tcNewMutVar Nothing `thenNF_Tc` \ box ->
+ returnNF_Tc (TcVarKind uniq box)
+
+newKindVars :: Int -> NF_TcM s [TcKind s]
+newKindVars n = mapNF_Tc (\_->newKindVar) (take n (repeat ()))
+\end{code}
+
+
+Kind unification
+~~~~~~~~~~~~~~~~
+\begin{code}
+unifyKind :: TcKind s -> TcKind s -> TcM s ()
+unifyKind kind1 kind2
+ = tcAddErrCtxtM ctxt (unify_kind kind1 kind2)
+ where
+ ctxt = zonkTcKind kind1 `thenNF_Tc` \ kind1' ->
+ zonkTcKind kind2 `thenNF_Tc` \ kind2' ->
+ returnNF_Tc (unifyKindCtxt kind1' kind2')
+
+
+unify_kind TcTypeKind TcTypeKind = returnTc ()
+
+unify_kind (TcArrowKind fun1 arg1)
+ (TcArrowKind fun2 arg2)
+
+ = unify_kind fun1 fun2 `thenTc_`
+ unify_kind arg1 arg2
+
+unify_kind (TcVarKind uniq box) kind = unify_var uniq box kind
+unify_kind kind (TcVarKind uniq box) = unify_var uniq box kind
+
+unify_kind kind1 kind2
+ = failTc (kindMisMatchErr kind1 kind2)
+\end{code}
+
+We could probably do some "shorting out" in unifyVarKind, but
+I'm not convinced it would save time, and it's a little tricky to get right.
+
+\begin{code}
+unify_var uniq1 box1 kind2
+ = tcReadMutVar box1 `thenNF_Tc` \ maybe_kind1 ->
+ case maybe_kind1 of
+ Just kind1 -> unify_kind kind1 kind1
+ Nothing -> unify_unbound_var uniq1 box1 kind2
+
+unify_unbound_var uniq1 box1 kind2@(TcVarKind uniq2 box2)
+ | uniq1 == uniq2 -- Binding to self is a no-op
+ = returnTc ()
+
+ | otherwise -- Distinct variables
+ = tcReadMutVar box2 `thenNF_Tc` \ maybe_kind2 ->
+ case maybe_kind2 of
+ Just kind2' -> unify_unbound_var uniq1 box1 kind2'
+ Nothing -> tcWriteMutVar box1 (Just kind2) `thenNF_Tc_`
+ -- No need for occurs check here
+ returnTc ()
+
+unify_unbound_var uniq1 box1 non_var_kind2
+ = occur_check non_var_kind2 `thenTc_`
+ tcWriteMutVar box1 (Just non_var_kind2) `thenNF_Tc_`
+ returnTc ()
+ where
+ occur_check TcTypeKind = returnTc ()
+ occur_check (TcArrowKind fun arg) = occur_check fun `thenTc_` occur_check arg
+ occur_check kind1@(TcVarKind uniq' box)
+ | uniq1 == uniq'
+ = failTc (kindOccurCheck kind1 non_var_kind2)
+
+ | otherwise -- Different variable
+ = tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
+ case maybe_kind of
+ Nothing -> returnTc ()
+ Just kind -> occur_check kind
+\end{code}
+
+The "occurs check" is necessary to catch situation like
+
+ type T k = k k
+
+
+Kind flattening
+~~~~~~~~~~~~~~~
+Coercions between TcKind and Kind
+
+\begin{code}
+kindToTcKind :: Kind -> TcKind s
+kindToTcKind TypeKind = TcTypeKind
+kindToTcKind BoxedTypeKind = TcTypeKind
+kindToTcKind UnboxedTypeKind = TcTypeKind
+kindToTcKind (ArrowKind k1 k2) = TcArrowKind (kindToTcKind k1) (kindToTcKind k2)
+
+
+tcKindToKind :: TcKind s -> NF_TcM s Kind
+
+tcKindToKind TcTypeKind
+ = returnNF_Tc TypeKind
+
+tcKindToKind (TcArrowKind kind1 kind2)
+ = tcKindToKind kind1 `thenNF_Tc` \ k1 ->
+ tcKindToKind kind2 `thenNF_Tc` \ k2 ->
+ returnNF_Tc (ArrowKind k1 k2)
+
+ -- Here's where we "default" unbound kinds to BoxedTypeKind
+tcKindToKind (TcVarKind uniq box)
+ = tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
+ case maybe_kind of
+ Nothing -> returnNF_Tc BoxedTypeKind -- Default is kind Type for unbound
+ Just kind -> tcKindToKind kind
+
+zonkTcKind :: TcKind s -> NF_TcM s (TcKind s)
+-- Removes variables that have now been bound.
+-- Mainly used just before an error message is printed,
+-- so that we don't need to follow through bound variables
+-- during error message construction.
+
+zonkTcKind TcTypeKind = returnNF_Tc TcTypeKind
+
+zonkTcKind (TcArrowKind kind1 kind2)
+ = zonkTcKind kind1 `thenNF_Tc` \ k1 ->
+ zonkTcKind kind2 `thenNF_Tc` \ k2 ->
+ returnNF_Tc (TcArrowKind k1 k2)
+
+zonkTcKind kind@(TcVarKind uniq box)
+ = tcReadMutVar box `thenNF_Tc` \ maybe_kind ->
+ case maybe_kind of
+ Nothing -> returnNF_Tc kind
+ Just kind' -> zonkTcKind kind'
+\end{code}
+
+
+\begin{code}
+instance Outputable (TcKind s) where
+ ppr sty kind = ppr_kind sty kind
+
+ppr_kind sty TcTypeKind
+ = ppStr "*"
+ppr_kind sty (TcArrowKind kind1 kind2)
+ = ppSep [ppr_parend sty kind1, ppStr "->", ppr_kind sty kind2]
+ppr_kind sty (TcVarKind uniq box)
+ = ppBesides [ppStr "k", pprUnique10 uniq]
+
+ppr_parend sty kind@(TcArrowKind _ _) = ppBesides [ppChar '(', ppr_kind sty kind, ppChar ')']
+ppr_parend sty other_kind = ppr_kind sty other_kind
+\end{code}
+
+
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+unifyKindCtxt kind1 kind2 sty
+ = ppHang (ppStr "When unifying two kinds") 4
+ (ppSep [ppr sty kind1, ppStr "and", ppr sty kind2])
+
+kindOccurCheck kind1 kind2 sty
+ = ppHang (ppStr "Cannot construct the infinite kind:") 4
+ (ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
+ ppStr "=",
+ ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
+ ppStr "(\"occurs check\")"])
+
+kindMisMatchErr kind1 kind2 sty
+ = ppHang (ppStr "Couldn't match the kind") 4
+ (ppSep [ppBesides [ppStr "`", ppr sty kind1, ppStr "'"],
+ ppStr "against",
+ ppBesides [ppStr "`", ppr sty kind1, ppStr "'"]
+ ])
+\end{code}
--- /dev/null
+This module breaks the loops among the typechecker modules
+TcExpr, TcBinds, TcMonoBnds, TcQuals, TcGRHSs, TcMatches.
+
+\begin{code}
+interface TcLoop where
+
+import TcGRHSs( tcGRHSsAndBinds )
+import HsMatches(GRHSsAndBinds)
+import HsPat(InPat, OutPat)
+import HsSyn(Fake)
+import TcHsSyn(TcIdOcc)
+import Name(Name)
+import TcType(TcMaybe)
+import SST(FSST_R)
+import Unique(Unique)
+import TyVar(GenTyVar)
+import TcEnv(TcEnv)
+import TcMonad(TcDown)
+import PreludeGlaST(_MutableArray)
+import Bag(Bag)
+import Type(GenType)
+import Inst(Inst)
+
+tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake Name (InPat Name)
+ -> TcDown a
+ -> TcEnv a
+ -> State# a
+ -> FSST_R a (GRHSsAndBinds (GenTyVar (_MutableArray a Int (TcMaybe a)))
+ Unique
+ (TcIdOcc a)
+ (OutPat (GenTyVar (_MutableArray a Int (TcMaybe a)))
+ Unique
+ (TcIdOcc a)),
+ Bag (Inst a),
+ GenType (GenTyVar (_MutableArray a Int (TcMaybe a))) Unique
+ )
+ ()
+\end{code}
--- /dev/null
+This module breaks the loops among the typechecker modules
+TcExpr, TcBinds, TcMonoBnds, TcQuals, TcGRHSs, TcMatches.
+
+\begin{code}
+module TcLoop( tcGRHSsAndBinds )
+import TcGRHSs( tcGRHSsAndBinds )
+\end{code}
--- /dev/null
+\begin{code}
+interface TcMLoop where
+
+import PreludeGlaST(_MutableArray)
+import TcEnv(TcEnv,initEnv)
+import TcType(TcMaybe)
+import TyVar(GenTyVar)
+import UniqFM(UniqFM)
+
+data TcEnv a
+data TcMaybe a
+initEnv :: _MutableArray a Int (UniqFM (GenTyVar (_MutableArray a Int (TcMaybe a)))) -> TcEnv a
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMatches where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsMatches(Match)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcMatch :: E -> Match Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Match Id TypecheckedPat, LIE, UniType)
-tcMatchesCase :: E -> [Match Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Match Id TypecheckedPat], LIE, UniType)
-tcMatchesFun :: E -> Name -> UniType -> [Match Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Match Id TypecheckedPat], LIE)
-
module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where
-import TcMonad -- typechecking monad machinery
-import TcMonadFns ( mkIdsWithOpenTyVarTys )
-import AbsSyn -- the stuff being typechecked
-
-import AbsPrel ( mkFunTy )
-import AbsUniType ( isTyVarTy, maybeUnpackFunTy )
-import E ( E, growE_LVE, LVE(..), GVE(..) )
-#if USE_ATTACK_PRAGMAS
-import CE
-import TCE
-#endif
-import Errors ( varyingArgsErr, Error(..), UnifyErrContext(..) )
-import LIE ( LIE, plusLIE )
-import Maybes ( Maybe(..) )
-import TcGRHSs ( tcGRHSsAndBinds )
+import Ubiq
+
+import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
+ HsExpr, HsBinds, OutPat, Fake,
+ collectPatBinders, pprMatch )
+import RnHsSyn ( RenamedMatch(..) )
+import TcHsSyn ( TcIdOcc(..), TcMatch(..) )
+
+import TcMonad
+import Inst ( Inst, LIE(..), plusLIE )
+import TcEnv ( newMonoIds )
+import TcLoop ( tcGRHSsAndBinds )
import TcPat ( tcPat )
+import TcType ( TcType(..), TcMaybe, zonkTcType )
import Unify ( unifyTauTy, unifyTauTyList )
+
+import Kind ( Kind, mkTypeKind )
+import Name ( Name )
+import Pretty
+import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
import Util
\end{code}
same number of arguments before using @tcMatches@ to do the work.
\begin{code}
-tcMatchesFun :: E -> Name
- -> UniType -- Expected type
+tcMatchesFun :: Name
+ -> TcType s -- Expected type
-> [RenamedMatch]
- -> TcM ([TypecheckedMatch], LIE)
+ -> TcM s ([TcMatch s], LIE s)
-tcMatchesFun e fun_name expected_ty matches@(first_match:_)
+tcMatchesFun fun_name expected_ty matches@(first_match:_)
= -- Set the location to that of the first equation, so that
-- any inter-equation error messages get some vaguely
-- sensible location. Note: we have to do this odd
-- ann-grabbing, because we don't always have annotations in
-- hand when we call tcMatchesFun...
- addSrcLocTc (get_Match_loc first_match) (
+ tcAddSrcLoc (get_Match_loc first_match) (
-- Check that they all have the same no of arguments
- checkTc (not (all_same (noOfArgs matches)))
+ checkTc (all_same (noOfArgs matches))
(varyingArgsErr fun_name matches) `thenTc_`
-- ToDo: Don't use "expected" stuff if there ain't a type signature
-- may show up as something wrong with the (non-existent) type signature
-- We need to substitute so that we can see as much about the type as possible
- applyTcSubstToTy expected_ty `thenNF_Tc` \ expected_ty' ->
- tcMatchesExpected e expected_ty' (\ m -> FunMonoBindsCtxt fun_name [m]) matches
+ zonkTcType expected_ty `thenNF_Tc` \ expected_ty' ->
+ tcMatchesExpected expected_ty' (MFun fun_name) matches
)
where
parser guarantees that each equation has exactly one argument.
\begin{code}
-tcMatchesCase :: E -> [RenamedMatch]
- -> TcM ([TypecheckedMatch], LIE, UniType)
-
-tcMatchesCase e matches
- =
-
- -- Typecheck them
- tcMatches e matches `thenTc` \ (matches', lie, tys@(first_ty:_)) ->
-
- -- Set the location to that of the first equation, so that
- -- any inter-equation error messages get some vaguely sensible location
- addSrcLocTc (get_Match_loc (head matches)) (
- unifyTauTyList tys (CaseBranchesCtxt matches)
- ) `thenTc_`
-
- returnTc (matches', lie, first_ty)
+tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
+tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
\end{code}
\begin{code}
-tcMatchesExpected :: E
- -> UniType
- -> (RenamedMatch -> UnifyErrContext)
- -> [RenamedMatch]
- -> TcM ([TypecheckedMatch], LIE)
-
-tcMatchesExpected e expected_ty err_ctxt_fn [match]
- = addSrcLocTc (get_Match_loc match) (
- tcMatchExpected e expected_ty (err_ctxt_fn match) match
- ) `thenTc` \ (match', lie) ->
+data FunOrCase = MCase | MFun Name -- Records whether doing fun or case rhss;
+ -- used to produced better error messages
+
+tcMatchesExpected :: TcType s
+ -> FunOrCase
+ -> [RenamedMatch]
+ -> TcM s ([TcMatch s], LIE s)
+
+tcMatchesExpected expected_ty fun_or_case [match]
+ = tcAddSrcLoc (get_Match_loc match) $
+ tcAddErrCtxt (matchCtxt fun_or_case match) $
+ tcMatchExpected expected_ty match `thenTc` \ (match', lie) ->
returnTc ([match'], lie)
-tcMatchesExpected e expected_ty err_ctxt_fn ms@(match1 : matches)
- = addSrcLocTc (get_Match_loc match1) (
- tcMatchExpected e expected_ty (err_ctxt_fn match1) match1
+tcMatchesExpected expected_ty fun_or_case (match1 : matches)
+ = tcAddSrcLoc (get_Match_loc match1) (
+ tcAddErrCtxt (matchCtxt fun_or_case match1) $
+ tcMatchExpected expected_ty match1
) `thenTc` \ (match1', lie1) ->
- tcMatchesExpected e expected_ty err_ctxt_fn matches `thenTc` \ (matches', lie2) ->
+ tcMatchesExpected expected_ty fun_or_case matches `thenTc` \ (matches', lie2) ->
returnTc (match1' : matches', plusLIE lie1 lie2)
-tcMatches :: E -> [RenamedMatch] -> TcM ([TypecheckedMatch], LIE, [UniType])
+tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s])
-tcMatches e [match]
- = tcMatch e match `thenTc` \ (match', lie, ty) ->
+tcMatches [match]
+ = tcAddSrcLoc (get_Match_loc match) $
+ tcMatch match `thenTc` \ (match', lie, ty) ->
returnTc ([match'], lie, [ty])
-tcMatches e ms@(match1 : matches)
- = addSrcLocTc (get_Match_loc match1) (
- tcMatch e match1
+tcMatches (match1 : matches)
+ = tcAddSrcLoc (get_Match_loc match1) (
+ tcMatch match1
) `thenTc` \ (match1', lie1, match1_ty) ->
- tcMatches e matches `thenTc` \ (matches', lie2, matches_ty) ->
+ tcMatches matches `thenTc` \ (matches', lie2, matches_ty) ->
returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
\end{code}
\begin{code}
-tcMatchExpected
- :: E
- -> UniType -- This gives the expected
+tcMatchExpected
+ :: TcType s -- This gives the expected
-- result-type of the Match. Early unification
-- with this guy gives better error messages
- -> UnifyErrContext
- -> RenamedMatch
- -> TcM (TypecheckedMatch,LIE)
- -- NB No type returned, because it was passed
- -- in instead!
+ -> RenamedMatch
+ -> TcM s (TcMatch s,LIE s) -- NB No type returned, because it was passed
+ -- in instead!
-tcMatchExpected e expected_ty err_ctxt the_match@(PatMatch pat match)
- = case maybeUnpackFunTy expected_ty of
+tcMatchExpected expected_ty the_match@(PatMatch pat match)
+ = case getFunTy_maybe expected_ty of
Nothing -> -- Not a function type (eg type variable)
-- So use tcMatch instead
- tcMatch e the_match `thenTc` \ (match', lie_match, match_ty) ->
- unifyTauTy match_ty expected_ty err_ctxt `thenTc_`
+ tcMatch the_match `thenTc` \ (match', lie_match, match_ty) ->
+ unifyTauTy match_ty expected_ty `thenTc_`
returnTc (match', lie_match)
Just (arg_ty,rest_ty) -> -- It's a function type!
let binders = collectPatBinders pat
in
- mkIdsWithOpenTyVarTys binders `thenNF_Tc` \ lve ->
- let e' = growE_LVE e lve
- in
- tcPat e' pat `thenTc` \ (pat', lie_pat, pat_ty) ->
-
- unifyTauTy arg_ty pat_ty err_ctxt `thenTc_`
- tcMatchExpected e' rest_ty err_ctxt match `thenTc` \ (match', lie_match) ->
- returnTc (PatMatch pat' match',
+ newMonoIds binders mkTypeKind (\ _ ->
+ tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
+ unifyTauTy arg_ty pat_ty `thenTc_`
+ tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
+ returnTc (PatMatch pat' match',
plusLIE lie_pat lie_match)
+ )
-tcMatchExpected e expected_ty err_ctxt (GRHSMatch grhss_and_binds)
- = tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
- unifyTauTy grhss_ty expected_ty err_ctxt `thenTc_`
+tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
+ = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
+ unifyTauTy grhss_ty expected_ty `thenTc_`
returnTc (GRHSMatch grhss_and_binds', lie)
-tcMatch :: E
- -> RenamedMatch
- -> TcM (TypecheckedMatch,LIE,UniType)
+tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
-tcMatch e (PatMatch pat match)
+tcMatch (PatMatch pat match)
= let binders = collectPatBinders pat
in
- mkIdsWithOpenTyVarTys binders `thenNF_Tc` \ lve ->
- let e' = growE_LVE e lve
- in
- tcPat e' pat `thenTc` \ (pat', lie_pat, pat_ty) ->
- tcMatch e' match `thenTc` \ (match', lie_match, match_ty) ->
-
--- We don't do this any more, do we?
--- applyTcSubstToTy pat_ty `thenNF_Tc`\ pat_ty' ->
-
- returnTc (PatMatch pat' match',
- plusLIE lie_pat lie_match,
- mkFunTy pat_ty match_ty)
+ newMonoIds binders mkTypeKind (\ _ ->
+ tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
+ tcMatch match `thenTc` \ (match', lie_match, match_ty) ->
+ returnTc (PatMatch pat' match',
+ plusLIE lie_pat lie_match,
+ mkFunTy pat_ty match_ty)
+ )
-tcMatch e (GRHSMatch grhss_and_binds)
- = tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
+tcMatch (GRHSMatch grhss_and_binds)
+ = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
\end{code}
get_GRHS_loc (OtherwiseGRHS _ locn) = locn
get_GRHS_loc (GRHS _ _ locn) = locn
\end{code}
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+matchCtxt MCase match sty
+ = ppHang (ppStr "In a \"case\" branch:")
+ 4 (pprMatch sty True{-is_case-} match)
+
+matchCtxt (MFun fun) match sty
+ = ppHang (ppBesides [ppStr "In an equation for function ", ppr sty fun, ppChar ':'])
+ 4 (ppBesides [ppr sty fun, pprMatch sty False{-not case-} match])
+\end{code}
+
+
+\begin{code}
+varyingArgsErr name matches sty
+ = ppSep [ppStr "Varying number of arguments for function", ppr sty name]
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcModule where
-import AbsSyn(Module)
-import Bag(Bag)
-import CE(CE(..))
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(InPat, RenamedPat(..), TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TCE(TCE(..))
-import TcInstDcls(InstInfo)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Module a b
-data Bag a
-type CE = UniqFM Class
-data E
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Binds a b
-data FixityDecl a
-data Expr a b
-data InPat a
-type RenamedPat = InPat Name
-data TypecheckedPat
-data Id
-data Inst
-data Labda a
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-data SrcLoc
-data Subst
-type TCE = UniqFM TyCon
-data InstInfo
-data TcResult a
-data UniqFM a
-tcModule :: E -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Module Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ((Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]), ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo), FiniteMap TyCon [(Bool, [Labda UniType])], E, PprStyle -> Int -> Bool -> PrettyRep)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcModule]{Typechecking a whole module}
#include "HsVersions.h"
module TcModule (
- tcModule,
-
- -- to make the interface self-sufficient...
- Module, Bag, CE(..), E, Binds, FixityDecl, Expr, InPat,
- RenamedPat(..), TypecheckedPat, Id, Inst, Maybe, TcResult,
- Name, ProtoName, SrcLoc, Subst, TCE(..), UniqFM,
- Error(..), Pretty(..), PprStyle, PrettyRep, InstInfo
+ tcModule
) where
-import TcMonad -- typechecking monad machinery
-import AbsSyn -- the stuff being typechecked
-
--- OLD:
---import AbsPrel ( stringTy,
--- eqStringId, neStringId, ltStringId,
--- leStringId, geStringId, gtStringId,
--- maxStringId, minStringId, tagCmpStringId,
--- dfunEqStringId, dfunOrdStringId,
--- pRELUDE_CORE
--- IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
--- )
---#if USE_ATTACK_PRAGMAS
---import PrelVals ( string_cmp_id ) -- shouldn't even be visible, really
---#endif
-import BackSubst ( applyTcSubstToBinds )
-import Bag ( unionBags, bagToList, emptyBag, listToBag )
-import CE ( nullCE, checkClassCycles, lookupCE, CE(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import E
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import InstEnv
-import LIE ( unMkLIE, plusLIE, LIE )
-import Name ( Name(..) )
-import RenameAuxFuns ( GlobalNameFuns(..), GlobalNameFun(..), ProtoName, Maybe )
-import SrcLoc ( mkBuiltinSrcLoc, SrcLoc )
-import TCE ( checkTypeCycles, TCE(..), UniqFM )
-import TcBinds ( tcTopBindsAndThen )
-import TcClassDcl ( tcClassDecls1, tcClassDecls2, ClassInfo )
+import Ubiq
+
+import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
+ TyDecl, SpecDataSig, ClassDecl, InstDecl,
+ SpecInstSig, DefaultDecl, Sig, Fake, InPat,
+ FixityDecl, IE, ImportedInterface )
+import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
+import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
+ TcIdOcc(..), zonkBinds, zonkInst, zonkId )
+
+import TcMonad
+import Inst ( Inst, plusLIE )
+import TcBinds ( tcBindsAndThen )
+import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
-import TcDeriv ( tcDeriving )
+import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
+ getEnv_TyCons, getEnv_Classes)
import TcIfaceSig ( tcInterfaceSigs )
-import TcInstDcls ( tcInstDecls1, tcInstDecls2, tcSpecInstSigs, buildInstanceEnvs, InstInfo(..) )
+import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
+import TcInstUtil ( buildInstanceEnvs, InstInfo )
import TcSimplify ( tcSimplifyTop )
-import TcTyDecls ( tcTyDecls )
-import Unique -- some ClassKey stuff
-import UniqFM ( emptyUFM ) -- profiling, pragmas only
+import TcTyClsDecls ( tcTyAndClassDecls1 )
+
+import Bag ( listToBag )
+import Class ( GenClass )
+import Id ( GenId, isDataCon, isMethodSelId, idType )
+import Maybes ( catMaybes )
+import Name ( Name(..) )
+import Outputable ( isExported )
+import PrelInfo ( unitTy, mkPrimIoTy )
+import Pretty
+import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+import TyCon ( TyCon )
+import Type ( applyTyCon )
+import Unify ( unifyTauTy )
+import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
+ filterUFM, eltsUFM )
+import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
import Util
-import Pretty -- Debugging
+
+import FiniteMap ( emptyFM )
+tycon_specs = emptyFM
+
+
\end{code}
\begin{code}
-tcModule :: E -- initial typechecker environment
- -> GlobalNameFuns -- final renamer info (to do derivings)
- -> RenamedModule -- input
- -> TcM ((TypecheckedBinds, -- binds from class decls; does NOT
+tcModule :: GlobalNameMappers -- final renamer info for derivings
+ -> RenamedHsModule -- input
+ -> TcM s ((TypecheckedHsBinds, -- binds from class decls; does NOT
-- include default-methods bindings
- TypecheckedBinds, -- binds from instance decls; INCLUDES
+ TypecheckedHsBinds, -- binds from instance decls; INCLUDES
-- class default-methods binds
- TypecheckedBinds, -- binds from value decls
- [(Inst, TypecheckedExpr)]),
+ TypecheckedHsBinds, -- binds from value decls
+
+ [(Id, TypecheckedHsExpr)]), -- constant instance binds
- ([RenamedFixityDecl], -- things for the interface generator
- [Id], -- to look at...
- CE,
- TCE,
- Bag InstInfo),
+ ([RenamedFixityDecl], [Id], UniqFM TyCon, UniqFM Class, Bag InstInfo),
+ -- things for the interface generator
- FiniteMap TyCon [(Bool, [Maybe UniType])],
+ (UniqFM TyCon, UniqFM Class),
+ -- environments of info from this module only
+
+ FiniteMap TyCon [(Bool, [Maybe Type])],
-- source tycon specialisation requests
---UNUSED: E, -- environment of total accumulated info
- E, -- environment of info due to this module only
- PprStyle -> Pretty) -- -ddump-deriving info (passed upwards)
+ PprStyle -> Pretty) -- -ddump-deriving info
+
+tcModule renamer_name_funs
+ (HsModule mod_name exports imports fixities
+ ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
+ default_decls val_decls sigs src_loc)
-tcModule e1 renamer_name_funs
- (Module mod_name exports imports_should_be_empty fixities
- tydecls ty_sigs classdecls instdecls specinst_sigs
- default_decls valdecls sigs src_loc)
+ = ASSERT(null imports)
- = addSrcLocTc src_loc ( -- record where we're starting
+ tcAddSrcLoc src_loc $ -- record where we're starting
-- Tie the knot for inteface-file value declaration signatures
-- This info is only used inside the knot for type-checking the
-- pragmas, which is done lazily [ie failure just drops the pragma
-- without having any global-failure effect].
- fixTc (\ ~(rec_gve_sigs, _, _, _, _, _, _, _, _, _) ->
- let
- e2 = plusE_GVE e1 rec_gve_sigs
- in
+ fixTc (\ ~(_, _, _, _, _, sig_ids) ->
+ tcExtendGlobalValEnv sig_ids (
-- The knot for instance information. This isn't used at all
- -- till we type-check value declarations.
- fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _, _, _, _) ->
-
- -- The knot for TyCons and Classes
- fixTc ( \ ~(_, rec_tce, rec_ce, rec_datacons_gve, rec_ops_gve, _, _) ->
- let
- e3 = e2
- `plusE_GVE` rec_datacons_gve
- `plusE_GVE` rec_ops_gve
- `plusE_TCE` rec_tce
- `plusE_CE` rec_ce
- in
- -- DO THE TYPE DECLS
- -- Including the pragmas: {-# ABSTRACT TypeSyn #-}
- -- {-# SPECIALIZE data DataType ... #-}
- let
- (absty_sigs, specdata_sigs) = partition is_absty_sig ty_sigs
- is_absty_sig (AbstractTypeSig _ _) = True
- is_absty_sig (SpecDataSig _ _ _) = False
-
- is_abs_syn :: Name -> Bool -- a lookup fn for abs synonyms
- is_abs_syn n
- = n `is_elem` [ tc | (AbstractTypeSig tc _) <- absty_sigs ]
- where
- is_elem = isIn "tcModule"
-
- get_spec_sigs :: Name -> [RenamedDataTypeSig]
- get_spec_sigs n
- = [ sig | sig@(SpecDataSig tc _ _) <- specdata_sigs, n == tc]
- in
- babyTcMtoTcM (tcTyDecls e3 is_abs_syn get_spec_sigs tydecls)
- `thenTc` \ (tce, datacons_gve, tycon_specs) ->
-
- -- DO THE CLASS DECLS
- tcClassDecls1 e3 rec_inst_mapper classdecls
- `thenTc` \ (class_info, ce, ops_gve) ->
-
- -- End of TyCon/Class knot
- -- Augment whatever TCE/GVE/CE stuff was in orig_e
- returnTc (e3, tce, ce, datacons_gve, ops_gve, class_info, tycon_specs)
-
- -- End of inner fixTc
- ) `thenTc` ( \ (e3, tce_here, ce_here, _, _, class_info, tycon_specs) ->
- -- The "here" things are the extra decls defined in this
- -- module or its imports; but not including whatever was
- -- in the incoming e.
-
- -- Grab completed tce/ce and check for type/class cycles
- -- The tce/ce are now stable and lookable-at, with the
- -- exception of the instance information inside classes
- let
- ce3 = getE_CE e3
- tce3 = getE_TCE e3
- in
- checkMaybeErrTc (checkTypeCycles tce3) id `thenTc_`
- checkMaybeErrTc (checkClassCycles ce3) id `thenTc_`
-
- -- Now instance declarations
- tcInstDecls1 e3 ce3 tce3 instdecls `thenNF_Tc` \ decl_inst_info ->
-
- -- Handle "derived" instances; note that we only do derivings
- -- for things in this module; we ignore deriving decls from
- -- interfaces! We pass fixities, because they may be used in
- -- doing Text.
-
- tcDeriving mod_name renamer_name_funs decl_inst_info tce3 fixities
- `thenTc` \ (deriv_inst_info, extra_deriv_binds, ddump_deriv) ->
-
- let
- inst_info = deriv_inst_info `unionBags` decl_inst_info
- in
- -- Handle specialise instance pragmas
- getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
- (if sw_chkr SpecialiseOverloaded then
- tcSpecInstSigs e3 ce3 tce3 inst_info specinst_sigs
- else
- returnTc emptyBag)
- `thenTc` \ spec_inst_info ->
- let
- full_inst_info = inst_info `unionBags` spec_inst_info
- in
- -- OK, now do the inst-mapper stuff
- buildInstanceEnvs full_inst_info `thenTc` \ all_insts_mapper ->
-
- returnTc (all_insts_mapper, e3, ce_here, tce_here, class_info, tycon_specs,
- full_inst_info, extra_deriv_binds, ddump_deriv)
-
- -- End of outer fixTc
- )) `thenTc` ( \ (_, e3, ce_here, tce_here, class_info, tycon_specs,
- full_inst_info, extra_deriv_binds, ddump_deriv) ->
-
- -- Default declarations
- tcDefaults e3 default_decls `thenTc` \ defaulting_tys ->
- setDefaultingTys defaulting_tys ( -- for the iface sigs...
-
- -- Interface type signatures
-
- -- We tie a knot so that the Ids read out of interfaces are in scope
- -- when we read their pragmas.
- -- What we rely on is that pragmas are typechecked lazily; if
- -- any type errors are found (ie there's an inconsistency)
- -- we silently discard the pragma
-
- babyTcMtoTcM (tcInterfaceSigs e3 sigs) `thenTc` \ gve_sigs ->
-
- returnTc (gve_sigs, e3, ce_here, tce_here, class_info, tycon_specs, defaulting_tys,
- full_inst_info, extra_deriv_binds, ddump_deriv)
-
- -- End of extremely outer fixTc
- ))) `thenTc` \ (_, e3, ce_here, tce_here, class_info, tycon_specs, defaulting_tys,
- full_inst_info, extra_deriv_binds, ddump_deriv) ->
-
- setDefaultingTys defaulting_tys ( -- to the end...
+ -- till we type-check value declarations
+ fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+
+ -- Type-check the type and class decls
+ trace "tcTyAndClassDecls:" $
+ tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
+ `thenTc` \ env ->
+
+ -- Typecheck the instance decls, includes deriving
+ tcSetEnv env (
+ trace "tcInstDecls:" $
+ tcInstDecls1 inst_decls_bag specinst_sigs
+ mod_name renamer_name_funs fixities
+ ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+
+ buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
+
+ returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+
+ ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+ tcSetEnv env (
+
+ -- Default declarations
+ tcDefaults default_decls `thenTc` \ defaulting_tys ->
+ tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
+
+ -- Interface type signatures
+ -- We tie a knot so that the Ids read out of interfaces are in scope
+ -- when we read their pragmas.
+ -- What we rely on is that pragmas are typechecked lazily; if
+ -- any type errors are found (ie there's an inconsistency)
+ -- we silently discard the pragma
+ tcInterfaceSigs sigs `thenTc` \ sig_ids ->
+
+ returnTc (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
+
+ )))) `thenTc` \ (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, _) ->
+
+ tcSetEnv env ( -- to the end...
+ tcSetDefaultTys defaulting_tys ( -- ditto
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
- -- Nota bene
- tcTopBindsAndThen
- e3
+ trace "tcBinds:" $
+ tcBindsAndThen
(\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
- (valdecls `ThenBinds` extra_deriv_binds)
- (\ e4 ->
- -- Second pass over instance declarations,
+ (val_decls `ThenBinds` deriv_binds)
+ ( -- Second pass over instance declarations,
-- to compile the bindings themselves.
- tcInstDecls2 e4 full_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
- tcClassDecls2 e4 class_info `thenNF_Tc` \ (lie_clasdecls, class_binds) ->
- returnTc ( (EmptyBinds, (inst_binds, class_binds, e4)),
+ tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+ tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
lie_instdecls `plusLIE` lie_clasdecls,
- () )
- )
+ () ))
+
+ `thenTc` \ ((val_binds, (inst_binds, cls_binds, final_env)), lie_alldecls, _) ->
- `thenTc` \ ((val_binds, (inst_binds, class_binds, e4)), lie_alldecls, _) ->
+ checkTopLevelIds mod_name final_env `thenTc_`
-- Deal with constant or ambiguous InstIds. How could
-- there be ambiguous ones? They can only arise if a
-- restriction, and no subsequent decl instantiates its
-- type. (Usually, ambiguous type variables are resolved
-- during the generalisation step.)
+ tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
+ let
+ localids = getEnv_LocalIds final_env
+ tycons = getEnv_TyCons final_env
+ classes = getEnv_Classes final_env
- tcSimplifyTop (unMkLIE lie_alldecls) `thenTc` \ const_inst_binds ->
+ local_tycons = filterUFM isLocallyDefined tycons
+ local_classes = filterUFM isLocallyDefined classes
+ exported_ids = [v | v <- eltsUFM localids,
+ isExported v && not (isDataCon v) && not (isMethodSelId v)]
+ in
-- Backsubstitution. Monomorphic top-level decls may have
-- been instantiated by subsequent decls, and the final
-- simplification step may have instantiated some
-- ambiguous types. So, sadly, we need to back-substitute
-- over the whole bunch of bindings.
-
- applyTcSubstToBinds val_binds `thenNF_Tc` \ val_binds' ->
- applyTcSubstToBinds inst_binds `thenNF_Tc` \ inst_binds' ->
- applyTcSubstToBinds class_binds `thenNF_Tc` \ class_binds' ->
-
- -- ToDo: probably need to back-substitute over all
- -- stuff in 'e4'; we do so here over the Ids,
- -- which is probably enough. WDP 95/06
- mapNF_Tc applyTcSubstToId (getE_GlobalVals e4)
- `thenNF_Tc` \ if_global_ids ->
+ zonkBinds val_binds `thenNF_Tc` \ val_binds' ->
+ zonkBinds inst_binds `thenNF_Tc` \ inst_binds' ->
+ zonkBinds cls_binds `thenNF_Tc` \ cls_binds' ->
+ mapNF_Tc zonkInst const_insts `thenNF_Tc` \ const_insts' ->
+ mapNF_Tc (zonkId.TcId) exported_ids `thenNF_Tc` \ exported_ids' ->
-- FINISHED AT LAST
returnTc (
- (class_binds', inst_binds', val_binds', const_inst_binds),
+ (cls_binds', inst_binds', val_binds', const_insts'),
-- the next collection is just for mkInterface
- (fixities, if_global_ids, ce_here, tce_here, full_inst_info),
+ (fixities, exported_ids', tycons, classes, inst_info),
- tycon_specs,
+ (local_tycons, local_classes),
---UNUSED: e4,
+ tycon_specs,
- -- and... TCE needed for code generation; rest needed for interpreter.
- -- ToDo: still wrong: needs isLocallyDeclared run over everything
- mkE tce_here {-gve_here lve-} ce_here,
- -- NB: interpreter would probably need the gve_here stuff
ddump_deriv
)))
+ where
+ ty_decls_bag = listToBag ty_decls
+ cls_decls_bag = listToBag cls_decls
+ inst_decls_bag = listToBag inst_decls
+
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Error checking code}
+%* *
+%************************************************************************
+
+
+checkTopLevelIds checks that Main.main or Main.mainPrimIO has correct type.
+
+\begin{code}
+checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s ()
+checkTopLevelIds mod final_env
+ = if (mod /= SLIT("Main")) then
+ returnTc ()
+ else
+ case (lookupUFM_Directly localids mainIdKey,
+ lookupUFM_Directly localids mainPrimIOIdKey) of
+ (Just main, Nothing) -> tcAddErrCtxt mainCtxt $
+ unifyTauTy ty_main (idType main)
+ (Nothing, Just prim) -> tcAddErrCtxt primCtxt $
+ unifyTauTy ty_prim (idType prim)
+ (Just _ , Just _ ) -> failTc mainBothIdErr
+ (Nothing, Nothing) -> failTc mainNoneIdErr
+ where
+ localids = getEnv_LocalIds final_env
+ tycons = getEnv_TyCons final_env
+
+ io_tc = lookupWithDefaultUFM_Directly tycons io_panic iOTyConKey
+ io_panic = panic "TcModule: type IO not in scope"
+
+ ty_main = applyTyCon io_tc [unitTy]
+ ty_prim = mkPrimIoTy unitTy
+
+
+mainCtxt sty
+ = ppStr "main should have type IO ()"
+
+primCtxt sty
+ = ppStr "mainPrimIO should have type PrimIO ()"
+
+mainBothIdErr sty
+ = ppStr "module Main contains definitions for both main and mainPrimIO"
+
+mainNoneIdErr sty
+ = panic "ToDo: sort out mainIdKey"
+ -- ppStr "module Main does not contain a definition for main (or mainPrimIO)"
+
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMonad where
-import Bag(Bag)
-import CharSeq(CSeq)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import ErrsTc(UnifyErrContext)
-import FiniteMap(FiniteMap)
-import HsBinds(Binds)
-import HsExpr(ArithSeqInfo, Expr, Qual, TypecheckedExpr(..))
-import HsLit(Literal)
-import HsMatches(GRHS, GRHSsAndBinds, Match)
-import HsPat(InPat, TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import IdInfo(IdInfo)
-import Inst(Inst)
-import Maybes(Labda, MaybeErr)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..))
-import RenameMonad4(Rn4M(..))
-import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import Unique(Unique, UniqueSupply)
-infixr 9 `thenLazilyNF_Tc`
-infixr 9 `thenNF_Tc`
-infixr 9 `thenTc`
-infixr 9 `thenTc_`
-type Baby_TcM a = (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-data Baby_TcResult a
-data Bag a
-data Class
-data GlobalSwitch
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Expr a b
-type NF_TcM a = (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-type TcM a = (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-data TcResult a
-data UnifyErrContext
-type TypecheckedExpr = Expr Id TypecheckedPat
-data TypecheckedPat
-data Id
-data IdInfo
-data Inst
-data Labda a
-data MaybeErr a b
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-type GlobalNameFun = ProtoName -> Labda Name
-type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
-type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply
-data SrcLoc
-data Subst
-data TyCon
-data TyVar
-data TyVarTemplate
-type SigmaType = UniType
-type TauType = UniType
-type ThetaType = [(Class, UniType)]
-data UniType
-data Unique
-data UniqueSupply
-addSrcLocB_Tc :: SrcLoc -> ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-addSrcLocTc :: SrcLoc -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-applyTcSubstToId :: Id -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToInst :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToInsts :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Inst], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToTy :: UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToTyVar :: TyVar -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstToTys :: [UniType] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-babyTcMtoNF_TcM :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-babyTcMtoTcM :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-checkB_Tc :: Bool -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ()
-checkMaybeErrTc :: MaybeErr b a -> (a -> PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
-checkMaybeTc :: Labda a -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-checkMaybesTc :: [Labda a] -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [a]
-checkTc :: Bool -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-failB_Tc :: (PprStyle -> Int -> Bool -> PrettyRep) -> a -> b -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> c -> Baby_TcResult d
-failTc :: (PprStyle -> Int -> Bool -> PrettyRep) -> a -> b -> Subst -> c -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> d -> TcResult e
-fixB_Tc :: (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-fixNF_Tc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-fixTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-foldlTc :: (b -> a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> b -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
-getDefaultingTys :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getSrcLocB_Tc :: a -> b -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> c -> Baby_TcResult c
-getSrcLocTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (SrcLoc, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getSwitchCheckerB_Tc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (GlobalSwitch -> Bool)
-getSwitchCheckerTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (GlobalSwitch -> Bool, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getTyVarUniqueTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Unique, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getTyVarUniquesTc :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Unique], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getUniqueB_Tc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult Unique
-getUniqueTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Unique, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-getUniquesB_Tc :: Int -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [Unique]
-getUniquesTc :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Unique], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-initTc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> MaybeErr a (Bag (PprStyle -> Int -> Bool -> PrettyRep))
-listNF_Tc :: [(GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([a], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-listTc :: [(GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [a]
-lookupInst_Tc :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Expr Id TypecheckedPat, [Inst])
-lookupNoBindInst_Tc :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [Inst]
-mapAndUnzipTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (b, c)) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([b], [c])
-mapB_Tc :: (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> [a] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [b]
-mapNF_Tc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (b, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([b], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mapTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [b]
-noFailTc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-pruneSubstTc :: [TyVar] -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-recoverIgnoreErrorsB_Tc :: e -> (b -> c -> Bag a -> d -> Baby_TcResult e) -> b -> c -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> d -> Baby_TcResult e
-recoverQuietlyTc :: a -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-recoverTc :: a -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-returnB_Tc :: a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-returnNF_Tc :: a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-returnTc :: a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-rn4MtoTcM :: (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((a, Bag (PprStyle -> Int -> Bool -> PrettyRep)), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-setDefaultingTys :: [UniType] -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-thenB_Tc :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b
-thenB_Tc_ :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b
-thenLazilyNF_Tc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b
-thenNF_Tc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b
-thenTc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
-thenTc_ :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
-uniqSMtoBabyTcM :: (SplitUniqSupply -> a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcMonad]{@TcMonad@: monad machinery for the typechecker}
-
\begin{code}
-#include "HsVersions.h"
-
-module TcMonad (
- TcM(..), TcResult{-abstract-},
- thenTc, thenTc_, returnTc, failTc, checkTc,
- listTc, mapTc, mapAndUnzipTc,
- fixTc, foldlTc, initTc,
- recoverTc, recoverQuietlyTc,
-
- NF_TcM(..),
- thenNF_Tc, thenLazilyNF_Tc, returnNF_Tc, listNF_Tc, mapNF_Tc,
- fixNF_Tc, noFailTc,
-
- Baby_TcM(..), Baby_TcResult{-abstract-},
- returnB_Tc, thenB_Tc, thenB_Tc_,
- failB_Tc, recoverIgnoreErrorsB_Tc,
- fixB_Tc, mapB_Tc,
- babyTcMtoTcM, babyTcMtoNF_TcM,
- getUniqueB_Tc, getUniquesB_Tc,
- addSrcLocB_Tc, getSrcLocB_Tc,
- getSwitchCheckerB_Tc, checkB_Tc,
- uniqSMtoBabyTcM,
-
- getSwitchCheckerTc,
- getDefaultingTys, setDefaultingTys,
- getUniquesTc, getUniqueTc,
- rn4MtoTcM,
-
- getTyVarUniquesTc, getTyVarUniqueTc,
-
- applyTcSubstToTy, applyTcSubstToTys,
---UNUSED: applyTcSubstToThetaTy,
- applyTcSubstToTyVar, applyTcSubstToTyVars,
- applyTcSubstToId,
- applyTcSubstToInst, applyTcSubstToInsts,
- extendSubstTc, pruneSubstTc,
-
- addSrcLocTc, getSrcLocTc,
- checkMaybeTc, checkMaybesTc,
- checkMaybeErrTc, -- UNUSED: checkMaybeErrsTc,
-
- lookupInst_Tc, lookupNoBindInst_Tc,
-
- -- and to make the interface self-sufficient ...
- UniqueSupply, SplitUniqSupply,
- Bag, Maybe, MaybeErr, Error(..), PprStyle, Pretty(..),
- PrettyRep, SrcLoc, Subst, TyVar, TyVarTemplate, TyCon,
- Class, UniType, TauType(..), ThetaType(..), SigmaType(..),
- UnifyErrContext, Unique, Expr,
- TypecheckedExpr(..), TypecheckedPat, Id, IdInfo, Inst,
- GlobalSwitch, SUniqSM(..), Rn4M(..), GlobalNameFuns(..),
- GlobalNameFun(..), Name, ProtoName
-
- IF_ATTACK_PRAGMAS(COMMA getSUnique COMMA getSUniques)
- IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA mkUniqueGrimily)
- IF_ATTACK_PRAGMAS(COMMA applySubstToId)
- IF_ATTACK_PRAGMAS(COMMA applySubstToInst)
- IF_ATTACK_PRAGMAS(COMMA applySubstToThetaTy)
- IF_ATTACK_PRAGMAS(COMMA applySubstToTy)
- IF_ATTACK_PRAGMAS(COMMA applySubstToTyVar)
- ) where
-
-import AbsSyn
-import AbsUniType ( TyVar, TyVarTemplate, TyCon, Class, UniType,
- TauType(..), ThetaType(..), SigmaType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Bag ( Bag, snocBag, emptyBag, isEmptyBag )
-import CmdLineOpts ( GlobalSwitch )
-import Errors ( noInstanceErr, unifyErr, pprBagOfErrors,
- Error(..), UnifyErrInfo(..), UnifyErrContext(..)
- )
-import FiniteMap ( emptyFM, FiniteMap )
-import Id ( applySubstToId )
-import Inst ( applySubstToInst )
-import InstEnv ( lookupInst, lookupNoBindInst, Inst )
-import Maybes ( Maybe(..), MaybeErr(..) )
-import Pretty
-import RenameMonad4 ( Rn4M(..), GlobalNameFuns(..), GlobalNameFun(..) )
-import SrcLoc ( mkUnknownSrcLoc )
-import Subst
-import Unify
-import SplitUniq
-import Unique
-import Util
-
-infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenLazilyNF_Tc`
-\end{code}
+module TcMonad(
+ TcM(..), NF_TcM(..), TcDown, TcEnv,
+ SST_R, FSST_R,
-%************************************************************************
-%* *
-\subsection[TcM-TcM]{Plain @TcM@ monadery}
-%* *
-%************************************************************************
+ initTc,
+ returnTc, thenTc, thenTc_, mapTc, listTc,
+ foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
+ mapBagTc, fixTc, tryTc,
-The following @TcM@ is of the garden variety which can fail, and does
-as soon as possible.
+ returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
+ listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
-\begin{code}
--- internal use only...
-type InTcM output
- = (GlobalSwitch -> Bool) -- so we can chk cmd-line switches
- -> [UniType] -- types used for defaulting; down only
- -> Subst -- substitution; threaded
- -> SplitUniqSupply -- threaded
- -> Bag Error -- threaded
- -> SrcLoc -- only passed downwards
- -> output
-
-data TcResult result
- = TcSucceeded result
- Subst
- (Bag Error)
- | TcFailed Subst
- (Bag Error)
-
-type TcM result
- = InTcM (TcResult result)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenTc #-}
-{-# INLINE thenTc_ #-}
-{-# INLINE returnTc #-}
-#endif
-
-thenTc :: TcM a -> (a -> TcM b) -> TcM b
-thenTc_ :: TcM a -> TcM b -> TcM b
-
-thenTc expr cont sw_chkr dtys subst us errs src_loc
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr sw_chkr dtys subst s1 errs src_loc) of
- TcFailed subst errs -> TcFailed subst errs
- TcSucceeded result subst2 errs2
- -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
- }
-
-thenTc_ expr cont sw_chkr dtys subst us errs src_loc
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr sw_chkr dtys subst s1 errs src_loc) of
- TcFailed subst errs -> TcFailed subst errs
- TcSucceeded _ subst2 errs2
- -> cont sw_chkr dtys subst2 s2 errs2 src_loc
- }
-
-returnTc :: a -> TcM a
-returnTc result sw_chkr dtys subst us errs src_loc
- = TcSucceeded result subst errs
-
-failTc err sw_chkr dtys subst us errs src_loc
- = TcFailed subst (errs `snocBag` err)
-\end{code}
+ checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
+ failTc, warnTc, recoverTc, recoverNF_Tc,
-@recoverTc@ recovers from an error, by providing a value to use
-instead. It is also lazy, in that it always succeeds immediately; the
-thing inside is only even looked at when you pull on the errors, or on
-the value returned.
+ tcGetEnv, tcSetEnv,
+ tcGetDefaultTys, tcSetDefaultTys,
+ tcGetUnique, tcGetUniques,
-@recoverQuietlyTc@ doesn't even report the errors found---it is used
-when looking at pragmas.
+ tcAddSrcLoc, tcGetSrcLoc,
+ tcAddErrCtxtM, tcSetErrCtxtM,
+ tcAddErrCtxt, tcSetErrCtxt,
-\begin{code}
-recoverTc, recoverQuietlyTc :: a -> TcM a -> NF_TcM a
+ tcNewMutVar, tcReadMutVar, tcWriteMutVar,
-recoverTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
- = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
- TcSucceeded result subst_out errs_out ->
- (result, combineSubstUndos subst_out, errs_out)
+ rn4MtoTcM,
- TcFailed subst_out errs_out ->
- (use_this_if_err, undoSubstUndos subst_out, errs_out)
- -- Note that we return the *undone* substitution
- -- and the *incoming* UniqueSupply
+ -- For closure
+ MutableVar(..), _MutableArray
+ ) where
+
+
+import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
+
+import Type ( Type(..), GenType )
+import TyVar ( TyVar(..), GenTyVar )
+import Usage ( Usage(..), GenUsage )
+import ErrUtils ( Error(..), Message(..), ErrCtxt(..),
+ TcWarning(..), TcError(..), mkTcErr )
+
+import SST
+import RnMonad4
+import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+
+import Bag ( Bag, emptyBag, isEmptyBag,
+ foldBag, unitBag, unionBags, snocBag )
+import FiniteMap ( FiniteMap, emptyFM )
+import Pretty ( Pretty(..), PrettyRep )
+import PprStyle ( PprStyle )
+import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+import Maybes ( MaybeErr(..) )
+import Name ( Name )
+import ProtoName ( ProtoName )
+import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
+import UniqFM ( UniqFM, emptyUFM )
+import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
+import Unique ( Unique )
+import Util
-recoverQuietlyTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
- = (r2, s2, e2)
- where
- (r2, s2, e2)
- = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
- TcSucceeded result subst_out errs_out ->
- (result, combineSubstUndos subst_out, errs_out)
-
- TcFailed subst_out errs_out ->
- (use_this_if_err, undoSubstUndos subst_out, errs_in)
- -- Note that we return the *undone* substitution,
- -- the *incoming* UniqueSupply, and the *incoming* errors
+infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
\end{code}
-The following @TcM@ checks a condition and fails with the given error
-message.
-\begin{code}
-checkTc :: Bool -> Error -> TcM ()
-
-checkTc True err = failTc err
-checkTc False err = returnTc ()
-
-listTc :: [TcM a] -> TcM [a]
-
-listTc [] = returnTc []
-listTc (x:xs)
- = x `thenTc` \ r ->
- listTc xs `thenTc` \ rs ->
- returnTc (r:rs)
-
-mapTc :: (a -> TcM b) -> [a] -> TcM [b]
-mapTc f [] = returnTc []
-mapTc f (x:xs)
- = f x `thenTc` \ r ->
- mapTc f xs `thenTc` \ rs ->
- returnTc (r:rs)
-
-mapAndUnzipTc :: (a -> TcM (b, c)) -> [a] -> TcM ([b], [c])
-
-mapAndUnzipTc f [] = returnTc ([], [])
-mapAndUnzipTc f (x:xs)
- = f x `thenTc` \ (r1, r2) ->
- mapAndUnzipTc f xs `thenTc` \ (rs1, rs2) ->
- returnTc (r1:rs1, r2:rs2)
-
-foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
-foldlTc f a [] = returnTc a
-foldlTc f a (b:bs) = f a b `thenTc` \ a2 ->
- foldlTc f a2 bs
-
-fixTc :: (x -> TcM x) -> TcM x
-fixTc m sw_chkr dtys subst us errs src_loc
- = lim
- where
- lim = m result sw_chkr dtys subst us errs src_loc
- result = case lim of
- TcSucceeded result _ _ -> result
-#ifdef DEBUG
- TcFailed _ errs -> pprPanic "Failed in fixTc:\n" (pprBagOfErrors PprDebug errs)
-#endif
-\end{code}
-
-And the machinery to start things up:
+\section{TcM, NF_TcM: the type checker monads}
+%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-aRRAY_SIZE :: Int
-aRRAY_SIZE = 511
-
-initTc :: (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> TcM result
- -> MaybeErr result (Bag Error)
-
-initTc sw_chkr us tc
- = case (tc sw_chkr [{-no defaults-}] init_subst us emptyBag mkUnknownSrcLoc) of
- TcFailed _ errs -> Failed errs
- TcSucceeded result subst2 errs
- -> if isEmptyBag errs then
- Succeeded result
- else
- Failed errs
-
-init_subst = mkEmptySubst aRRAY_SIZE -- out here to avoid initTc CAF...sigh
+type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
+type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
\end{code}
-
-%************************************************************************
-%* *
-\subsection[TcM-NF_TcM]{No-fail @NF_TcM@ monadery}
-%* *
-%************************************************************************
-
-This is a no-fail version of a TcM.
-
\begin{code}
--- ToDo: re-order fields to match TcM?
-type NF_TcM result = InTcM (result, Subst, Bag Error)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenNF_Tc #-}
-{-# INLINE thenLazilyNF_Tc #-}
-{-# INLINE returnNF_Tc #-}
-#endif
-
-thenNF_Tc, thenLazilyNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b
--- ...Lazily... is purely a performance thing (WDP 95/09)
+-- With a builtin polymorphic type for _runSST the type for
+-- initTc should use TcM s r instead of TcM _RealWorld r
+
+initTc :: UniqSupply
+ -> TcM _RealWorld r
+ -> MaybeErr (r, Bag TcWarning)
+ (Bag TcError, Bag TcWarning)
+
+initTc us do_this
+ = _runSST (
+ newMutVarSST us `thenSST` \ us_var ->
+ newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
+ newMutVarSST emptyUFM `thenSST` \ tvs_var ->
+ let
+ init_down = TcDown [] us_var
+ mkUnknownSrcLoc
+ [] errs_var
+ init_env = initEnv tvs_var
+ in
+ recoverSST
+ (\_ -> returnSST Nothing)
+ (do_this init_down init_env `thenFSST` \ res ->
+ returnFSST (Just res))
+ `thenSST` \ maybe_res ->
+ readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ case (maybe_res, isEmptyBag errs) of
+ (Just res, True) -> returnSST (Succeeded (res, warns))
+ _ -> returnSST (Failed (errs, warns))
+ )
+
+thenNF_Tc :: NF_TcM s a
+ -> (a -> TcDown s -> TcEnv s -> State# s -> b)
+ -> TcDown s -> TcEnv s -> State# s -> b
+-- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
+-- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
+
+thenNF_Tc m k down env
+ = m down env `thenSST` \ r ->
+ k r down env
+
+thenNF_Tc_ :: NF_TcM s a
+ -> (TcDown s -> TcEnv s -> State# s -> b)
+ -> TcDown s -> TcEnv s -> State# s -> b
+-- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
+-- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
+
+thenNF_Tc_ m k down env
+ = m down env `thenSST_` k down env
+
+returnNF_Tc :: a -> NF_TcM s a
+returnNF_Tc v down env = returnSST v
+
+mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
+mapNF_Tc f [] = returnNF_Tc []
+mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
+ mapNF_Tc f xs `thenNF_Tc` \ rs ->
+ returnNF_Tc (r:rs)
+
+listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
+listNF_Tc [] = returnNF_Tc []
+listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
+ listNF_Tc xs `thenNF_Tc` \ rs ->
+ returnNF_Tc (r:rs)
+
+mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
+mapBagNF_Tc f bag
+ = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
+ b2 `thenNF_Tc` \ r2 ->
+ returnNF_Tc (unionBags r1 r2))
+ (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
+ (returnNF_Tc emptyBag)
+ bag
+
+mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
+mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
+mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
+ mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
+ returnNF_Tc (r1:rs1, r2:rs2)
+
+thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
+thenTc m k down env
+ = m down env `thenFSST` \ r ->
+ k r down env
+
+thenTc_ :: TcM s a -> TcM s b -> TcM s b
+thenTc_ m k down env
+ = m down env `thenFSST_` k down env
+
+returnTc :: a -> TcM s a
+returnTc val down env = returnFSST val
+
+mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
+mapTc f [] = returnTc []
+mapTc f (x:xs) = f x `thenTc` \ r ->
+ mapTc f xs `thenTc` \ rs ->
+ returnTc (r:rs)
+
+listTc :: [TcM s a] -> TcM s [a]
+listTc [] = returnTc []
+listTc (x:xs) = x `thenTc` \ r ->
+ listTc xs `thenTc` \ rs ->
+ returnTc (r:rs)
+
+foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
+foldrTc k z [] = returnTc z
+foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
+ k x r
+
+foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
+foldlTc k z [] = returnTc z
+foldlTc k z (x:xs) = k z x `thenTc` \r ->
+ foldlTc k r xs
+
+mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
+mapAndUnzipTc f [] = returnTc ([],[])
+mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
+ mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
+ returnTc (r1:rs1, r2:rs2)
+
+mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
+mapAndUnzip3Tc f [] = returnTc ([],[],[])
+mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
+ mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
+ returnTc (r1:rs1, r2:rs2, r3:rs3)
+
+mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
+mapBagTc f bag
+ = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
+ b2 `thenTc` \ r2 ->
+ returnTc (unionBags r1 r2))
+ (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
+ (returnTc emptyBag)
+ bag
+
+fixTc :: (a -> TcM s a) -> TcM s a
+fixTc m env down = fixFSST (\ loop -> m loop env down)
\end{code}
-In particular, @thenNF_Tc@ has all of these types:
+@forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
+This elegantly ensures that it can't zap any type variables that
+belong to the main thread. We throw away any error messages!
+
\begin{pseudocode}
-thenNF_Tc :: NF_TcM a -> (a -> TcM b) -> TcM b
-thenNF_Tc :: NF_TcM a -> (a -> NF_TcM b) -> NF_TcM b
+forkNF_Tc :: NF_TcM s r -> NF_TcM s r
+forkNF_Tc m down env
+ = forkTcDown down `thenSST` \ down' ->
+ returnSST (_runSST (m down' (forkTcEnv env)))
\end{pseudocode}
-\begin{code}
-thenNF_Tc expr cont sw_chkr dtys subst us errs src_loc
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr sw_chkr dtys subst s1 errs src_loc) of
- (result, subst2, errs2)
- -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
- }
-
-thenLazilyNF_Tc expr cont sw_chkr dtys subst us errs src_loc
- = let
- (s1, s2) = splitUniqSupply us
- in
- case (expr sw_chkr dtys subst s1 errs src_loc) of {
- (result, subst2, errs2)
- -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
- }
-
-returnNF_Tc :: a -> NF_TcM a
-returnNF_Tc result sw_chkr dtys subst us errs src_loc
- = (result, subst, errs)
-
-listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
-listNF_Tc [] = returnNF_Tc []
-listNF_Tc (x:xs)
- = x `thenNF_Tc` \ r ->
- listNF_Tc xs `thenNF_Tc` \ rs ->
- returnNF_Tc (r:rs)
-
-mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
-mapNF_Tc f [] = returnNF_Tc []
-mapNF_Tc f (x:xs)
- = f x `thenNF_Tc` \ r ->
- mapNF_Tc f xs `thenNF_Tc` \ rs ->
- returnNF_Tc (r:rs)
-
-fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
-fixNF_Tc m sw_chkr dtys subst us errs src_loc
- = lim
- where
- lim = m result sw_chkr dtys subst us errs src_loc
- (result, _, _) = lim
-\end{code}
-
-@noFailTc@ takes a \tr{TcM a} and returns a \tr{NF_TcM a}. You use it
-when you are darn sure that the TcM won't actually fail!
-
-\begin{code}
-noFailTc :: TcM a -> NF_TcM a
-
-noFailTc expr sw_chkr dtys subst us errs src_loc
- = case (expr sw_chkr dtys subst us errs src_loc) of
- TcFailed _ _ -> panic "Failure in noFailTc!"
- TcSucceeded result subst errs
- -> (result, subst, errs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TcM-uniq-extract]{Extractings Uniques from the monad}
-%* *
-%************************************************************************
-
-These functions extract uniques from the monad. There are two unique
-supplies embedded in the monad.
-\begin{itemize}
-\item
-normal unique supply
-\item
-special unique supply for TyVars (these index the substitution)
-\end{itemize}
+Error handling
+~~~~~~~~~~~~~~
\begin{code}
-getUniquesTc :: Int -> NF_TcM [Unique]
-getUniquesTc n sw_chkr dtys subst us errs src_loc
- = case (getSUniques n us) of { uniques ->
- (uniques, subst, errs) }
-
--- This simpler version is often adequate:
-
-getUniqueTc :: NF_TcM Unique
-getUniqueTc sw_chkr dtys subst us errs src_loc
- = case (getSUnique us) of { unique ->
- (unique, subst, errs) }
-
-rn4MtoTcM :: GlobalNameFuns -> Rn4M a -> NF_TcM (a, Bag Error)
-
-rn4MtoTcM name_funs rn_action sw_chkr dtys subst us errs src_loc
- = let
- (rn_result, rn_errs)
- = rn_action sw_chkr name_funs emptyFM emptyBag us mkUnknownSrcLoc
- -- laziness may be good for you (see below)
+failTc :: Message -> TcM s a
+failTc err_msg down env
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ foldr thenNF_Tc_ (returnNF_Tc []) ctxt down env `thenSST` \ ctxt_msgs ->
+ let
+ err = mkTcErr loc ctxt_msgs err_msg
in
- ((rn_result, rn_errs), subst, errs)
-
--- Special uniques for TyVars extracted from the substitution
-
-getTyVarUniquesTc :: Int -> NF_TcM [Unique]
-getTyVarUniquesTc n sw_chkr dtys subst us errs src_loc
- = returnNF_Tc uniques sw_chkr dtys subst2 us errs src_loc
+ writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
+ failFSST ()
where
- (subst2, uniques) = getSubstTyVarUniques n subst
-
-getTyVarUniqueTc :: NF_TcM Unique
-getTyVarUniqueTc sw_chkr dtys subst us errs src_loc
- = returnNF_Tc unique sw_chkr dtys subst2 us errs src_loc
+ errs_var = getTcErrs down
+ ctxt = getErrCtxt down
+ loc = getLoc down
+
+warnTc :: Bool -> Message -> NF_TcM s ()
+warnTc warn_if_true warn down env
+ = if warn_if_true then
+ readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
+ returnSST ()
+ else
+ returnSST ()
where
- (subst2, unique) = getSubstTyVarUnique subst
+ errs_var = getTcErrs down
+
+recoverTc :: TcM s r -> TcM s r -> TcM s r
+recoverTc recover m down env
+ = recoverFSST (\ _ -> recover down env) (m down env)
+
+recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
+recoverNF_Tc recover m down env
+ = recoverSST (\ _ -> recover down env) (m down env)
+
+-- (tryTc r m) tries m; if it succeeds it returns it,
+-- otherwise it returns r. Any error messages added by m are discarded,
+-- whether or not m succeeds.
+tryTc :: TcM s r -> TcM s r -> TcM s r
+tryTc recover m down env
+ = recoverFSST (\ _ -> recover down env) $
+ newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
+ m (setTcErrs down new_errs_var) env
+
+checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
+checkTc True err = returnTc ()
+checkTc False err = failTc err
+
+checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
+checkTcM True err = returnTc ()
+checkTcM False err = err
+
+checkMaybeTc :: Maybe val -> Message -> TcM s val
+checkMaybeTc (Just val) err = returnTc val
+checkMaybeTc Nothing err = failTc err
+
+checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
+checkMaybeTcM (Just val) err = returnTc val
+checkMaybeTcM Nothing err = err
\end{code}
-%************************************************************************
-%* *
-\subsection[TcM-extract]{Extractings other things from the monad}
-%* *
-%************************************************************************
-
-These are functions which extract things from the monad.
-
-Extending and applying the substitution.
-
-ToDo: Unify.lhs BackSubst.lhs Id.lhs Inst.lhs: The TcMonad is used in
-a number of places where only the sequenced substitution is required.
-A lighter weight sequence substitution monad would be more appropriate
-with TcMonad interface functions defined here.
-
+Mutable variables
+~~~~~~~~~~~~~~~~~
\begin{code}
-getTcSubst :: NF_TcM Subst
-applyTcSubstToTy :: TauType -> NF_TcM TauType
---UNUSED:applyTcSubstToThetaTy :: ThetaType -> NF_TcM ThetaType
-applyTcSubstToTyVar :: TyVar -> NF_TcM TauType
-applyTcSubstToId :: Id -> NF_TcM Id
-applyTcSubstToInst :: Inst -> NF_TcM Inst
-
-getTcSubst sw_chkr dtys subst us errs src_loc
- = returnNF_Tc subst sw_chkr dtys subst us errs src_loc
-
-applyTcSubstToTy ty sw_chkr dtys subst us errs src_loc
- = case (applySubstToTy subst ty) of { (subst2, new_tau_ty) ->
- returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
- }
-
-{- UNUSED:
-applyTcSubstToThetaTy theta_ty sw_chkr dtys subst us errs src_loc
- = case (applySubstToThetaTy subst theta_ty) of { (subst2, new_theta_ty) ->
- returnNF_Tc new_theta_ty sw_chkr dtys subst2 us errs src_loc
- }
--}
-
-applyTcSubstToTyVar tyvar sw_chkr dtys subst us errs src_loc
- = case (applySubstToTyVar subst tyvar) of { (subst2, new_tau_ty) ->
- returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
- }
-
-applyTcSubstToId tyvar sw_chkr dtys subst us errs src_loc
- = case (applySubstToId subst tyvar) of { (subst2, new_tau_ty) ->
- returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
- }
-
-applyTcSubstToInst inst sw_chkr dtys subst us errs src_loc
- = case (applySubstToInst subst inst) of { (subst2, new_inst) ->
- returnNF_Tc new_inst sw_chkr dtys subst2 us errs src_loc
- }
-
-applyTcSubstToTyVars :: [TyVar] -> NF_TcM [UniType]
-applyTcSubstToTys :: [TauType] -> NF_TcM [TauType]
-
-applyTcSubstToTyVars tyvars = mapNF_Tc applyTcSubstToTyVar tyvars
-applyTcSubstToTys tys = mapNF_Tc applyTcSubstToTy tys
-applyTcSubstToInsts insts = mapNF_Tc applyTcSubstToInst insts
-\end{code}
+tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
+tcNewMutVar val down env = newMutVarSST val
-\begin{code}
-extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> TcM ()
-
-extendSubstTc tyvar ty err_ctxt sw_chkr dtys subst us errs src_loc
- = case (extendSubst tyvar ty subst) of { (new_subst, extend_result) ->
- case extend_result of
- SubstOK ->
- TcSucceeded () new_subst errs
-
- OccursCheck tyvar ty ->
- TcFailed new_subst
- (errs `snocBag` (unifyErr (TypeRec tyvar ty) err_ctxt src_loc))
-
- AlreadyBound ty1 ->
- -- This should only happen in the case of a call to
- -- extendSubstTc from the unifier! The way things are now
- -- we can't check for the AlreadyBound case in other calls
- -- to extendSubstTc, but we're confident it never shows up.
- -- Ugh!
- unifyTauTy ty1 ty err_ctxt sw_chkr dtys new_subst us errs src_loc
- }
+tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
+tcWriteMutVar var val down env = writeMutVarSST var val
+
+tcReadMutVar :: MutableVar s a -> NF_TcM s a
+tcReadMutVar var down env = readMutVarSST var
\end{code}
-@pruneSubstTc@ does nothing with an array substitution implementation!!!
+Environment
+~~~~~~~~~~~
\begin{code}
-pruneSubstTc :: [TyVar] -- Type vars whose substitutions should be kept
- -> TcM a -- Type-check this
- -> TcM a -- Return same result but pruned subst
+tcGetEnv :: NF_TcM s (TcEnv s)
+tcGetEnv down env = returnSST env
-pruneSubstTc keep_tyvars m sw_chkr dtys subst uniqs errs src_loc
- = m sw_chkr dtys subst uniqs errs src_loc
+tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
+tcSetEnv new_env m down old_env = m down new_env
\end{code}
-\begin{code}
-getSwitchCheckerTc :: NF_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerTc sw_chkr = returnNF_Tc sw_chkr sw_chkr
-\end{code}
+Source location
+~~~~~~~~~~~~~~~
\begin{code}
-getDefaultingTys :: NF_TcM [UniType]
-getDefaultingTys sw_chkr dtys = returnNF_Tc dtys sw_chkr dtys
+tcGetDefaultTys :: NF_TcM s [Type]
+tcGetDefaultTys down env = returnSST (getDefaultTys down)
-setDefaultingTys :: [UniType] -> TcM a -> TcM a
-setDefaultingTys dtys action sw_chkr _ subst us errs src_loc
- = action sw_chkr dtys subst us errs src_loc
-\end{code}
-
-\begin{code}
-addSrcLocTc :: SrcLoc -> TcM a -> TcM a
-addSrcLocTc new_locn expr sw_chkr dtys subst us errs src_loc
- = expr sw_chkr dtys subst us errs new_locn
+tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
+tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
-getSrcLocTc :: NF_TcM SrcLoc
-getSrcLocTc sw_chkr dtys subst us errs src_loc
- = (src_loc, subst, errs)
-\end{code}
+tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
+tcAddSrcLoc loc m down env = m (setLoc down loc) env
-%************************************************************************
-%* *
-\subsection[TcM-check]{Error-detecting functions}
-%* *
-%************************************************************************
+tcGetSrcLoc :: NF_TcM s SrcLoc
+tcGetSrcLoc down env = returnSST (getLoc down)
-The following TcM checks a Maybe type and fails with the given
-error message.
+tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
+tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
+tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
-\begin{code}
-checkMaybeTc :: Maybe val -> Error -> TcM val
-checkMaybeTc (Just result) err = returnTc result
-checkMaybeTc Nothing err = failTc err
-
-checkMaybesTc :: [Maybe val] -> Error -> TcM [val]
-checkMaybesTc [] err = returnTc []
-checkMaybesTc (Nothing:xs) err = failTc err
-checkMaybesTc ((Just v):xs) err
- = checkMaybesTc xs err `thenTc` \ xs2 ->
- returnTc (v:xs2)
-
-checkMaybeErrTc :: MaybeErr val err -> (err -> Error) -> TcM val
-checkMaybeErrTc (Succeeded result) errfun = returnTc result
-checkMaybeErrTc (Failed err) errfun = failTc (errfun err)
-
-{- UNUSED:
-checkMaybeErrsTc :: [MaybeErr val err] -> (err -> Error) -> TcM [val]
-
-checkMaybeErrsTc [] err_fun = returnTc []
-checkMaybeErrsTc ((Failed err) :xs) err_fun = failTc (err_fun err)
-checkMaybeErrsTc ((Succeeded v):xs) err_fun
- = checkMaybeErrsTc xs err_fun `thenTc` \ xs2 ->
- returnTc (v:xs2)
--}
+tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
+tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
+tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
\end{code}
-%************************************************************************
-%* *
-\subsection[TcM-Insts]{Looking up instances}
-%* *
-%************************************************************************
+Unique supply
+~~~~~~~~~~~~~
\begin{code}
-lookupInst_Tc :: Inst -> TcM (TypecheckedExpr, [Inst])
-
-lookupInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
- = case (lookupInst uniqs inst) of
- Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
-
- Just (expr, insts) -> TcSucceeded (expr, insts) subst errs
-
-lookupNoBindInst_Tc :: Inst -> TcM [Inst]
-
-lookupNoBindInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
- = case (lookupNoBindInst uniqs inst) of
- Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
-
- Just insts -> TcSucceeded insts subst errs
+tcGetUnique :: NF_TcM s Unique
+tcGetUnique down env
+ = readMutVarSST u_var `thenSST` \ uniq_supply ->
+ let
+ (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniq = getUnique uniq_s
+ in
+ writeMutVarSST u_var new_uniq_supply `thenSST_`
+ returnSST uniq
+ where
+ u_var = getUniqSupplyVar down
+
+tcGetUniques :: Int -> NF_TcM s [Unique]
+tcGetUniques n down env
+ = readMutVarSST u_var `thenSST` \ uniq_supply ->
+ let
+ (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniqs = getUniques n uniq_s
+ in
+ writeMutVarSST u_var new_uniq_supply `thenSST_`
+ returnSST uniqs
+ where
+ u_var = getUniqSupplyVar down
\end{code}
-
-
-
-
-
-%************************************************************************
-%* *
-\subsection[Baby_TcM]{``Baby'' @TcM@ monadery---when we don't need the full bang}
-%* *
-%************************************************************************
-
-The "baby" Tc monad doesn't pass around the substitution.
-That means you can't use it to type-check bindings, but you can use
-if for everything else (interfaces, type decls, first pass of class and
-instance decls etc).
-
-Less importantly, it doesn't pass around the list of default decls either.
-
-
-Type declarations
-~~~~~~~~~~~~~~~~~
+\section{TcDown}
+%~~~~~~~~~~~~~~~
\begin{code}
-type Baby_TcM result
- = (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> Bag Error -- threaded
- -> SrcLoc -- only passed downwards
- -> Baby_TcResult result
+data TcDown s
+ = TcDown
+ [Type] -- Types used for defaulting
-data Baby_TcResult result
- = BabyTcFailed (Bag Error)
+ (MutableVar s UniqSupply) -- Unique supply
- | BabyTcSucceeded result (Bag Error)
-\end{code}
+ SrcLoc -- Source location
+ (ErrCtxt s) -- Error context
+ (MutableVar s (Bag TcWarning,
+ Bag TcError))
+type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
+ -- to deal with bound type variables just before error
+ -- message construction
+\end{code}
-Standard plumbing
-~~~~~~~~~~~~~~~~~
+-- These selectors are *local* to TcMonad.lhs
\begin{code}
-thenB_Tc :: Baby_TcM a -> (a -> Baby_TcM b) -> Baby_TcM b
-returnB_Tc :: a -> Baby_TcM a
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenB_Tc #-}
-{-# INLINE returnB_Tc #-}
-#endif
-
-thenB_Tc a b sw us errs loc
- = case (splitUniqSupply us) of { (s1, s2) ->
- case (a sw s1 errs loc) of
- BabyTcFailed errs2 -> BabyTcFailed errs2
- BabyTcSucceeded a_res errs2 -> b a_res sw s2 errs2 loc
- }
-
-returnB_Tc result sw us errs loc = BabyTcSucceeded result errs
-failB_Tc err sw us errs loc = BabyTcFailed (errs `snocBag` err)
-
-recoverIgnoreErrorsB_Tc return_on_failure try_this sw us errs loc
- = BabyTcSucceeded result errs
- where
- result = case try_this sw us emptyBag loc of
- BabyTcSucceeded result errs_from_branch -> result
- BabyTcFailed errs_from_branch -> return_on_failure
+getTcErrs (TcDown def us loc ctxt errs) = errs
+setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
-fixB_Tc :: (a -> Baby_TcM a) -> Baby_TcM a
-fixB_Tc k sw us errs loc
- = result
- where
- result = k val sw us errs loc
- val = case result of
- BabyTcSucceeded val errs -> val
- BabyTcFailed errs -> panic "fixB_Tc failed"
-
-babyTcMtoTcM :: Baby_TcM a -> TcM a
-babyTcMtoTcM m sw_chkr dtys subst us errs src_loc
- = case m sw_chkr us errs src_loc of
- BabyTcSucceeded result errs2 -> TcSucceeded result subst errs2
- BabyTcFailed errs2 -> TcFailed subst errs2
-
-babyTcMtoNF_TcM :: Baby_TcM a -> NF_TcM a
-babyTcMtoNF_TcM m sw_chkr dtys subst us errs src_loc
- = case m sw_chkr us errs src_loc of
- BabyTcSucceeded result errs2 -> (result, subst, errs2)
- BabyTcFailed errs2 -> panic "babyTcMtoNF_TcM"
-\end{code}
+getDefaultTys (TcDown def us loc ctxt errs) = def
+setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
-\begin{code}
-uniqSMtoBabyTcM :: SUniqSM a -> Baby_TcM a
+getLoc (TcDown def us loc ctxt errs) = loc
+setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
-uniqSMtoBabyTcM u_action sw us errs loc
- = let
- u_result = u_action us
- -- at least one use *needs* this laziness
- in
- BabyTcSucceeded u_result errs
-\end{code}
+getUniqSupplyVar (TcDown def us loc ctxt errs) = us
-\begin{code}
-thenB_Tc_ m k = m `thenB_Tc` \ _ ->
- k
-
-mapB_Tc :: (a -> Baby_TcM b) -> [a] -> Baby_TcM [b]
-mapB_Tc f [] = returnB_Tc []
-mapB_Tc f (x:xs) = f x `thenB_Tc` \ fx ->
- mapB_Tc f xs `thenB_Tc` \ fxs ->
- returnB_Tc (fx:fxs)
+setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
+addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
+getErrCtxt (TcDown def us loc ctxt errs) = ctxt
\end{code}
-
-Primitives
-~~~~~~~~~~
+@forkTcDown@ makes a new "down" blob for a lazily-computed fork
+of the type checker.
\begin{code}
-getUniqueB_Tc :: Baby_TcM Unique
-getUniquesB_Tc :: Int -> Baby_TcM [Unique]
-
-getUniqueB_Tc sw us errs loc
- = case (getSUnique us) of { unique ->
- BabyTcSucceeded unique errs }
-
-getUniquesB_Tc n sw us errs loc
- = case (getSUniques n us) of { uniques ->
- BabyTcSucceeded uniques errs }
-
-addSrcLocB_Tc :: SrcLoc -> Baby_TcM a -> Baby_TcM a
-addSrcLocB_Tc new_locn m sw us errs loc
- = m sw us errs new_locn
+forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
+ = -- Get a fresh unique supply
+ readMutVarSST u_var `thenSST` \ us ->
+ let
+ (us1, us2) = splitUniqSupply us
+ in
+ writeMutVarSST u_var us1 `thenSST_`
-getSrcLocB_Tc sw us errs loc = BabyTcSucceeded loc errs
+ -- Make fresh MutVars for the unique supply and errors
+ newMutVarSST us2 `thenSST` \ u_var' ->
+ newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
-getSwitchCheckerB_Tc :: Baby_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerB_Tc sw_chkr us errs loc = BabyTcSucceeded sw_chkr errs
+ -- Done
+ returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
\end{code}
-Useful functions
-~~~~~~~~~~~~~~~~
+\section{rn4MtoTcM}
+%~~~~~~~~~~~~~~~~~~
\begin{code}
-checkB_Tc :: Bool -> Error -> Baby_TcM ()
+rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
-checkB_Tc True err = failB_Tc err
-checkB_Tc False err = returnB_Tc ()
+rn4MtoTcM name_funs rn_action down env
+ = readMutVarSST u_var `thenSST` \ uniq_supply ->
+ let
+ (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ in
+ writeMutVarSST u_var new_uniq_supply `thenSST_`
+ let
+ (rn_result, rn_errs)
+ = rn_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc
+ in
+ returnSST (rn_result, rn_errs)
+ where
+ u_var = getUniqSupplyVar down
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMonadFns where
-import Bag(Bag)
-import Class(Class, ClassOp)
-import CmdLineOpts(GlobalSwitch)
-import ErrUtils(Error(..))
-import ErrsTc(UnifyErrContext)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsExpr(ArithSeqInfo, Expr)
-import HsLit(Literal)
-import HsMatches(GRHSsAndBinds, Match)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import IdInfo(IdInfo, SpecEnv, SpecInfo)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import InstEnv(InstTemplate)
-import Maybes(Labda)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique, UniqueSupply)
-data Bag a
-data Class
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data UnifyErrContext
-data Binds a b
-data MonoBinds a b
-data TypecheckedPat
-data Id
-data SpecInfo
-data Inst
-data InstOrigin
-data OverloadedLit
-data Labda a
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data SrcLoc
-data Subst
-data TcResult a
-data TyVar
-data UniType
-data UniqueSupply
-applyTcSubstAndCollectTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([TyVar], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-applyTcSubstAndExpectTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([TyVar], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-copyTyVars :: [TyVarTemplate] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (([(TyVarTemplate, UniType)], [TyVar], [UniType]), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mkIdsWithGivenTys :: [Name] -> [UniType] -> [IdInfo] -> [(Name, Id)]
-mkIdsWithOpenTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([(Name, Id)], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-mkIdsWithPolyTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([(Name, Id)], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newClassOpLocals :: [(TyVarTemplate, UniType)] -> [ClassOp] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newDict :: InstOrigin -> Class -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newDicts :: InstOrigin -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Inst], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newLocalWithGivenTy :: Name -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newLocalsWithOpenTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newLocalsWithPolyTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newMethod :: InstOrigin -> Id -> [UniType] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newOpenTyVarTy :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newOverloadedLit :: InstOrigin -> OverloadedLit -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newPolyTyVarTy :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newPolyTyVarTys :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newSpecId :: Id -> [Labda UniType] -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-newSpecPragmaId :: Name -> UniType -> Labda SpecInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcMonadFns]{Auxilliary functions for typechecker monad}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcMonadFns (
- newDict, newDicts, newMethod, newOverloadedLit,
-
- copyTyVars,
- newOpenTyVarTy, newPolyTyVarTy,
- newPolyTyVarTys,
-
---UNUSED: newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy,
- newLocalWithGivenTy,
- newSpecPragmaId, newSpecId,
- newClassOpLocals,
- newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys,
-
- mkIdsWithOpenTyVarTys, mkIdsWithPolyTyVarTys,
- mkIdsWithGivenTys,
-
- applyTcSubstAndCollectTyVars,
- applyTcSubstAndExpectTyVars,
-
- -- and to make the interface self-sufficient...
- Bag, Class, Binds, MonoBinds, TypecheckedPat, Id, Inst, SpecInfo,
- OverloadedLit, InstOrigin, TcResult, Name, SrcLoc, Subst, Maybe,
- Error(..), TyVar, UniType, UnifyErrContext, UniqueSupply,
- PprStyle, Pretty(..), PrettyRep
- ) where
-
-import TcMonad -- the underlying monadery
-import AbsSyn
-
-import AbsUniType
-import Id ( mkId, mkUserLocal, mkSpecPragmaId, mkSpecId,
- selectIdInfoForSpecId, Id, DictVar(..) )
-import IdInfo
-import Inst ( mkDict, mkMethod, mkLitInst,
- Inst(..), -- .. for pragmas
- OverloadedLit, InstOrigin
- )
-import Maybes ( Maybe(..) )
-import E ( LVE(..) )
-import Errors ( Error(..), UnifyErrInfo )
-import Unique ( Unique, UniqueSupply )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TcMonadFns-newNameThings]{Making new things from the name supply}
-%* *
-%************************************************************************
-
-@newPolyTyVars@ takes list of ``old'' template type vars, and manufactures
-a list of freshly-uniqued type vars.
-
-\begin{code}
-copyTyVars :: [TyVarTemplate] -- Old type vars
- -> NF_TcM
- ([(TyVarTemplate,TauType)],--Old-to-new assoc list
- [TyVar], -- New type vars
- [TauType]) -- New type vars wrapped in a UniTyVar
-
-copyTyVars old_tyvars
- = getTyVarUniquesTc (length old_tyvars) `thenNF_Tc` \ new_uniqs ->
- returnNF_Tc (instantiateTyVarTemplates old_tyvars new_uniqs)
-
-newOpenTyVarTys :: Int -> NF_TcM [UniType]
-newOpenTyVarTys n
- = getTyVarUniquesTc n `thenLazilyNF_Tc` \ new_uniqs ->
- returnNF_Tc [mkTyVarTy (mkOpenSysTyVar u) | u <- new_uniqs]
-
-newPolyTyVarTys :: Int -> NF_TcM [UniType]
-newPolyTyVarTys n
- = getTyVarUniquesTc n `thenLazilyNF_Tc` \ new_uniqs ->
- returnNF_Tc [mkTyVarTy (mkPolySysTyVar u) | u <- new_uniqs]
-
-newOpenTyVarTy, newPolyTyVarTy :: NF_TcM UniType
-newOpenTyVarTy
- = getTyVarUniqueTc `thenLazilyNF_Tc` \ new_uniq ->
- returnNF_Tc (mkTyVarTy (mkOpenSysTyVar new_uniq))
-
-newPolyTyVarTy
- = getTyVarUniqueTc `thenLazilyNF_Tc` \ new_uniq ->
- returnNF_Tc (mkTyVarTy (mkPolySysTyVar new_uniq))
-\end{code}
-
-The functions @newDicts@, @newMethod@, and @newOverloadedLit@ build
-new @Inst@s.
-
-\begin{code}
-newDicts :: InstOrigin -> ThetaType -> NF_TcM [Inst]
-newDicts orig theta
- = getUniquesTc (length theta) `thenNF_Tc` \ new_uniqs ->
- returnNF_Tc (zipWith mk_dict_var new_uniqs theta)
- where
- mk_dict_var u (clas, ty) = mkDict u clas ty orig
-
-newDict :: InstOrigin -> Class -> UniType -> NF_TcM Inst
-newDict orig clas ty
- = getUniqueTc `thenNF_Tc` \ new_uniq ->
- returnNF_Tc (mkDict new_uniq clas ty orig)
-
-newMethod :: InstOrigin -> Id -> [UniType] -> NF_TcM Inst
-newMethod orig id tys
- = getUniqueTc `thenNF_Tc` \ new_uniq ->
- returnNF_Tc (mkMethod new_uniq id tys orig)
-
-newOverloadedLit :: InstOrigin -> OverloadedLit -> UniType -> NF_TcM Inst
-newOverloadedLit orig lit ty
- = getUniqueTc `thenNF_Tc` \ new_uniq ->
- returnNF_Tc (mkLitInst new_uniq lit ty orig)
-\end{code}
-
-Make a fresh batch of locals, derived from name, each typed with a fresh
-type variable, and return an LVE of them.
-\begin{itemize}
-
-\item @mkIdsWithTyVarTys@ uses the supplied names directly (including their
- uniques), and generates a @TopId@ or @Local@ depending on whether
- the name is a @FullName@ or not.
-
-\item @mkIdsWithGivenTys@ does as above, but the types are supplied.
-\end{itemize}
-
-\begin{code}
-mkIdsWithPolyTyVarTys, mkIdsWithOpenTyVarTys :: [Name] -> NF_TcM LVE
-mkIdsWithPolyTyVarTys names
- = let
- no_of_names = length names
- in
- newPolyTyVarTys no_of_names `thenNF_Tc` \ tys ->
- returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo))
-
-mkIdsWithOpenTyVarTys names
- = let
- no_of_names = length names
- in
- newOpenTyVarTys no_of_names `thenNF_Tc` \ tys ->
- returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo))
-
-mkIdsWithGivenTys :: [Name] -> [UniType] -> [IdInfo] -> LVE
- -- not monadic any more (WDP 94/05)
- -- Not done w/ zips/etc for "efficiency" (?)
-mkIdsWithGivenTys [] [] _ = []
-mkIdsWithGivenTys (name:names) (ty:tys) (id_info:id_infos)
- = (name, mkId name ty id_info) : mkIdsWithGivenTys names tys id_infos
-
-newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys :: [Name] -> NF_TcM [Id]
-newLocalsWithOpenTyVarTys = new_locals_given_tyvar_fun newOpenTyVarTys
-newLocalsWithPolyTyVarTys = new_locals_given_tyvar_fun newPolyTyVarTys
-
-new_locals_given_tyvar_fun new_tyvar_fun names
- = new_tyvar_fun no_of_names `thenNF_Tc` \ tys ->
- getUniquesTc no_of_names `thenNF_Tc` \ uniqs ->
- let ids = zipWith3 mk_local names uniqs tys in
- returnNF_Tc ids
- where
- no_of_names = length names
- mk_local name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
- (getSrcLoc name)
-\end{code}
-
-@newLocal*@ creates a new unique local variable with the given
-string and type. @newLocals@ is similar, but works on lists of strings
-and types.
-
-\begin{code}
-{- UNUSED:
-newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy :: Name -> NF_TcM Id
-
-newLocalWithOpenTyVarTy name
- = newOpenTyVarTy `thenNF_Tc` \ ty ->
- newLocalWithGivenTy name ty
-
-newLocalWithPolyTyVarTy name
- = newPolyTyVarTy `thenNF_Tc` \ ty ->
- newLocalWithGivenTy name ty
--}
-
-newLocalWithGivenTy :: Name -> UniType -> NF_TcM Id
-newLocalWithGivenTy name ty
- = getUniqueTc `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkUserLocal (getOccurrenceName name) uniq ty (getSrcLoc name))
-
-newSpecPragmaId :: Name -> UniType -> Maybe SpecInfo -> NF_TcM Id
-newSpecPragmaId name ty specinfo
- = getUniqueTc `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkSpecPragmaId (getOccurrenceName name) uniq ty specinfo (getSrcLoc name))
-
-newSpecId :: Id -> [Maybe UniType] -> UniType -> NF_TcM Id
-newSpecId unspec spec_tys ty
- = getUniqueTc `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkSpecId uniq unspec spec_tys ty (selectIdInfoForSpecId unspec))
-\end{code}
-
-ToDo: This @newClassOpLocals@ is used only to make new ClassOps. Pretty yukky.
-
-\begin{code}
-newClassOpLocals :: [(TyVarTemplate, TauType)]
- -- The class type variable mapped to
- -- the instance type (an InstTyEnv)
- -> [ClassOp] -- The class ops
- -> NF_TcM [Id] -- Suitable Ids for the polymorphic
- -- methods
-newClassOpLocals inst_env ops
- = getSrcLocTc `thenNF_Tc` \ src_loc ->
- getUniquesTc (length ops) `thenNF_Tc` \ uniqs ->
- returnNF_Tc (zipWith (new_local src_loc) ops uniqs)
- where
- new_local src_loc op uniq
- = mkUserLocal (getClassOpString op)
- uniq
- (instantiateTy inst_env (getClassOpLocalType op))
- src_loc
-\end{code}
-
-%************************************************************************
-%* *
-Back-substitution functions. These just apply the current
-substitution to their argument(s).
-%* *
-%************************************************************************
-
-@applyTcSubstAndCollectTyVars@ applies a substitution to a list of type
-variables, takes the free type vars of the resulting types, and
-returns all of them as list without duplications.
-
-\begin{code}
-applyTcSubstAndCollectTyVars :: [TyVar] -> NF_TcM [TyVar]
-applyTcSubstAndCollectTyVars tyvars
- = applyTcSubstToTyVars tyvars `thenNF_Tc` \ tys ->
- returnNF_Tc (extractTyVarsFromTys tys)
-
-applyTcSubstAndExpectTyVars :: [TyVar] -> NF_TcM [TyVar]
-applyTcSubstAndExpectTyVars tyvars
- = applyTcSubstToTyVars tyvars `thenNF_Tc` \ tys ->
- returnNF_Tc (map (getTyVar "applyTcSubstAndExpectTyVars") tys)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMonoBnds where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsBinds(MonoBinds)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcMonoBinds :: E -> MonoBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (MonoBinds Id TypecheckedPat, LIE)
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcMonoBinds]{TcMonoBinds}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcMonoBnds ( tcMonoBinds ) where
-
-import TcMonad -- typechecking monad machinery
-import AbsSyn -- the stuff being typechecked
-
-import AbsPrel ( mkPrimIoTy, unitTy, mkListTy, mkFunTy )
-import AbsUniType ( applyNonSynTyCon, applySynTyCon )
-import CmdLineOpts ( GlobalSwitch(..) )
-import E ( growE_LVE, lookupE_Binder, getE_TCE, E, GVE(..), LVE(..) )
-#if USE_ATTACK_PRAGMAS
-import CE
-#endif
-import TCE
-import Errors ( UnifyErrContext(..) ) -- notably PatMonoBindsCtxt
-import Id ( getIdUniType, Id )
-import LIE ( nullLIE, plusLIE, LIE )
-import NameTypes ( FullName )
-import TcGRHSs ( tcGRHSsAndBinds )
-import TcMatches ( tcMatchesFun )
-import TcPat ( tcPat )
-import Unify ( unifyTauTy )
-import Unique ( dialogueTyConKey, iOTyConKey )
-import Util
-\end{code}
-
-\begin{code}
-tcMonoBinds :: E -> RenamedMonoBinds -> TcM (TypecheckedMonoBinds, LIE)
-
-tcMonoBinds e EmptyMonoBinds = returnTc (EmptyMonoBinds, nullLIE)
-
-tcMonoBinds e (AndMonoBinds mb1 mb2)
- = tcMonoBinds e mb1 `thenTc` \ (mb1a, lie1) ->
- tcMonoBinds e mb2 `thenTc` \ (mb2a, lie2) ->
- returnTc (AndMonoBinds mb1a mb2a, plusLIE lie1 lie2)
-
-tcMonoBinds e (PatMonoBind pat grhss_and_binds locn)
- -- much like tcMatches of GRHSMatch
- = addSrcLocTc locn (
-
- -- LEFT HAND SIDE
- tcPat e pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
-
- -- BINDINGS AND THEN GRHSS
- tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
-
- unifyTauTy pat_ty grhss_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_`
-
- (case pat of
- VarPatIn fun -> chk_main_or_mainIOish_type e fun pat_ty
- _ -> returnTc (panic "chk_main_or_mainIOish_type (pat)")
- ) `thenTc_`
-
- -- Check for primitive types in the pattern (no can do)
-{- does not work here
- checkTc (any_con_w_prim_arg pat2)
- (error "Can't have primitive type in a pattern binding") `thenTc_`
--}
-
- -- RETURN
- returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
- plusLIE lie_pat lie)
- )
-
-tcMonoBinds e (FunMonoBind name matches locn)
- = addSrcLocTc locn (
- let id = lookupE_Binder e name in
-
- tcMatchesFun e name (getIdUniType id) matches `thenTc` \ (matches', lie) ->
-
- chk_main_or_mainIOish_type e name (getIdUniType id) `thenTc_`
-
- returnTc (FunMonoBind id matches' locn, lie)
- )
-
-chk_main_or_mainIOish_type :: E -> Name -> UniType -> TcM ()
-
- -- profoundly ugly checking that ...
- -- Main.main :: Dialogue -- Haskell 1.2
- -- Main.main :: IO () -- Haskell 1.3
- -- Main.mainPrimIO :: PrimIO () -- Glasgow extension
-
-chk_main_or_mainIOish_type e name chk_ty
- = getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
- let
- tce = getE_TCE e
- haskell_1_3 = sw_chkr Haskell_1_3
-
-{-OLD: response_tc = lookupTCE tce (PreludeTyCon responseTyConKey bottom 0 True)
- request_tc = lookupTCE tce (PreludeTyCon requestTyConKey bottom 0 True)
- response_ty = applyNonSynTyCon response_tc []
- request_ty = applyNonSynTyCon request_tc []
- dialogue_ty = (mkListTy response_ty) `mkFunTy` (mkListTy request_ty)
--}
- dialogue_tc = lookupTCE tce (PreludeTyCon dialogueTyConKey bottom 0 False)
- dialogue_ty = applySynTyCon dialogue_tc []
-
- io_tc = lookupTCE tce (PreludeTyCon iOTyConKey bottom 1 False)
- io_tup0_ty = applySynTyCon io_tc [unitTy]
-
- bottom = panic "chk_main_or..."
- in
- if is_a_particular_thing SLIT("Main") SLIT("main") name then
- if haskell_1_3 then
- unifyTauTy io_tup0_ty chk_ty (MatchCtxt io_tup0_ty chk_ty)
- else
- unifyTauTy dialogue_ty chk_ty (MatchCtxt dialogue_ty chk_ty)
-
- else if is_a_particular_thing SLIT("Main") SLIT("mainPrimIO") name then
- let
- ioprim_ty = mkPrimIoTy unitTy
- in
- unifyTauTy ioprim_ty chk_ty (MatchCtxt ioprim_ty chk_ty)
- else
- returnTc bottom
- where
- is_a_particular_thing :: FAST_STRING -> FAST_STRING -> Name -> Bool
-
- is_a_particular_thing mod_wanted nm_wanted (OtherTopId _ full_name)
- = let (mod, nm) = getOrigName full_name
- in mod == mod_wanted && nm == nm_wanted
- is_a_particular_thing _ _ _ = False
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcMonoType where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import HsTypes(MonoType)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcInstanceType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> Bool -> SrcLoc -> MonoType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType
-tcMonoType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> MonoType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
#include "HsVersions.h"
-module TcMonoType ( tcMonoType, tcInstanceType ) where
+module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
-import Pretty
+import Ubiq{-uitous-}
-import TcMonad -- typechecking monad machinery
-import AbsSyn -- the stuff being typechecked
-
-#ifndef DPH
-import AbsPrel ( mkListTy, mkTupleTy, mkFunTy )
-#else
-import AbsPrel ( mkListTy, mkTupleTy, mkFunTy, mkProcessorTy, mkPodTy )
-#endif {- Data Parallel Haskell -}
-import AbsUniType ( applySynTyCon, applyNonSynTyCon, mkDictTy,
- getTyConArity, isSynTyCon, isTyVarTemplateTy,
- getUniDataTyCon_maybe, maybeUnpackFunTy
- IF_ATTACK_PRAGMAS(COMMA pprTyCon COMMA pprUniType)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+import HsSyn ( PolyType(..), MonoType(..), Fake )
+import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
+ RenamedContext(..)
)
-import UniType ( UniType(..) ) -- ******** CHEATING **** could be undone
-import TyCon --( TyCon(..) ) -- ditto, only more so
-import CE ( lookupCE, CE(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Errors ( confusedNameErr, tyConArityErr, instTypeErr,
- Error(..)
+
+import TcMonad
+import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
+ tcExtendTyVarEnv, tcTyVarScope
+ )
+import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
+ mkTcArrowKind, unifyKind, newKindVar,
+ kindToTcKind
)
-import Maybes ( Maybe(..) )
-import TcPolyType ( tcPolyType )
-import TCE ( lookupTCE, TCE(..), UniqFM )
-import TVE ( lookupTVE, TVE(..) )
-import Util
+import ErrUtils ( arityErr )
+import Type ( GenType, Type(..), ThetaType(..),
+ mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy,
+ mkSigmaTy
+ )
+import TyVar ( GenTyVar, TyVar(..), mkTyVar )
+import PrelInfo ( mkListTy, mkTupleTy )
+import Type ( mkDictTy )
+import Class ( cCallishClassKeys )
+import Unique ( Unique )
+import Name ( Name(..), getNameShortName, isTyConName, getSynNameArity )
+import PprStyle
+import Pretty
+import Util ( zipWithEqual, panic )
\end{code}
+
+tcMonoType and tcMonoTypeKind
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+tcMonoType checks that the type really is of kind Type!
+
\begin{code}
-tcMonoType :: CE -> TCE -> TVE -> RenamedMonoType -> Baby_TcM UniType
-
-tcMonoType rec_ce rec_tce tve (MonoTyVar name)
- = returnB_Tc (lookupTVE tve name)
-
-tcMonoType rec_ce rec_tce tve (ListMonoTy ty)
- = tcMonoType rec_ce rec_tce tve ty `thenB_Tc` \ tau_ty ->
- returnB_Tc (mkListTy tau_ty)
-
-tcMonoType rec_ce rec_tce tve (TupleMonoTy tys)
- = mapB_Tc (tcPolyType rec_ce rec_tce tve) tys `thenB_Tc` \ tau_tys ->
- returnB_Tc (mkTupleTy (length tau_tys) tau_tys)
-
-tcMonoType rec_ce rec_tce tve (FunMonoTy ty1 ty2)
- = tcMonoType rec_ce rec_tce tve ty1 `thenB_Tc` \ tau_ty1 ->
- tcMonoType rec_ce rec_tce tve ty2 `thenB_Tc` \ tau_ty2 ->
- returnB_Tc (mkFunTy tau_ty1 tau_ty2)
-
-tcMonoType rec_ce rec_tce tve (MonoTyCon name@(WiredInTyCon tycon) tys)
- = let
- arity = getTyConArity tycon
- is_syn_tycon = isSynTyCon tycon
- in
- tcMonoType_help rec_ce rec_tce tve name tycon arity is_syn_tycon tys
-
-tcMonoType rec_ce rec_tce tve (MonoTyCon name@(PreludeTyCon _ _ arity is_data_tycon) tys)
- = tcMonoType_help rec_ce rec_tce tve name
- (lookupTCE rec_tce name)
- arity (not is_data_tycon) tys
-
-
-tcMonoType rec_ce rec_tce tve (MonoTyCon name@(OtherTyCon _ _ arity is_data_tycon _) tys)
- = tcMonoType_help rec_ce rec_tce tve name
- (lookupTCE rec_tce name)
- arity (not is_data_tycon) tys
-
-tcMonoType rec_ce rec_tce tve (MonoTyCon bad_name tys)
- = getSrcLocB_Tc `thenB_Tc` \ locn ->
- failB_Tc (confusedNameErr
- "Bad name for a type constructor (a class, or a Prelude name?)"
- bad_name locn)
-
--- two for unfoldings only:
-tcMonoType rec_ce rec_tce tve (MonoDict c ty)
- = tcMonoType rec_ce rec_tce tve ty `thenB_Tc` \ new_ty ->
- let
- clas = lookupCE rec_ce c
- in
- returnB_Tc (mkDictTy clas new_ty)
-
-tcMonoType rec_ce rec_tce tve (MonoTyVarTemplate tv_tmpl)
- = returnB_Tc (lookupTVE tve tv_tmpl)
-
-#ifdef DPH
-tcMonoType ce tce tve (MonoTyProc tys ty)
- = tcMonoTypes ce tce tve tys `thenB_Tc` \ tau_tys ->
- tcMonoType ce tce tve ty `thenB_Tc` \ tau_ty ->
- returnB_Tc (mkProcessorTy tau_tys tau_ty)
-
-tcMonoType ce tce tve (MonoTyPod ty)
- = tcMonoType ce tce tve ty `thenB_Tc` \ tau_ty ->
- returnB_Tc (mkPodTy tau_ty)
-#endif {- Data Parallel Haskell -}
-
-#ifdef DEBUG
-tcMonoType rec_ce rec_tce tve bad_ty
- = pprPanic "tcMonoType:" (ppr PprShowAll bad_ty)
-#endif
+tcMonoType :: RenamedMonoType -> TcM s Type
+
+tcMonoType ty
+ = tcMonoTypeKind ty `thenTc` \ (kind,ty) ->
+ unifyKind kind mkTcTypeKind `thenTc_`
+ returnTc ty
\end{code}
+tcMonoTypeKind does the real work. It returns a kind and a type.
+
\begin{code}
-tcMonoType_help rec_ce rec_tce tve name tycon arity is_syn_tycon tys
- = tcMonoTypes rec_ce rec_tce tve tys `thenB_Tc` \ tau_tys ->
- let cur_arity = length tys in
- getSrcLocB_Tc `thenB_Tc` \ loc ->
-
- checkB_Tc (arity /= cur_arity)
- (tyConArityErr name arity cur_arity loc) `thenB_Tc_`
-
- returnB_Tc (if is_syn_tycon then
- applySynTyCon tycon tau_tys
- else
- applyNonSynTyCon tycon tau_tys)
-
--- also not exported
-tcMonoTypes rec_ce rec_tce tve monotypes
- = mapB_Tc (tcMonoType rec_ce rec_tce tve) monotypes
+tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
+
+tcMonoTypeKind (MonoTyVar name)
+ = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+ returnTc (kind, mkTyVarTy tyvar)
+
+
+tcMonoTypeKind (MonoListTy ty)
+ = tcMonoType ty `thenTc` \ tau_ty ->
+ returnTc (mkTcTypeKind, mkListTy tau_ty)
+
+tcMonoTypeKind (MonoTupleTy tys)
+ = mapTc tcMonoType tys `thenTc` \ tau_tys ->
+ returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
+
+tcMonoTypeKind (MonoFunTy ty1 ty2)
+ = tcMonoType ty1 `thenTc` \ tau_ty1 ->
+ tcMonoType ty2 `thenTc` \ tau_ty2 ->
+ returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
+
+tcMonoTypeKind (MonoTyApp name tys)
+ = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
+
+ tc_mono_name name `thenNF_Tc` \ (fun_kind, fun_ty) ->
+
+ newKindVar `thenNF_Tc` \ result_kind ->
+ unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
+
+ -- Check for saturated application in the special case of
+ -- type synoyms. Here the renamer has kindly attached the
+ -- arity to the Name.
+ synArityCheck name (length tys) `thenTc_`
+
+ returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
+
+-- for unfoldings only:
+tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
+ = tcExtendTyVarEnv tyvar_names (tc_kinds `zip` tyvars) (
+ tcMonoTypeKind ty `thenTc` \ (kind, ty') ->
+ unifyKind kind mkTcTypeKind `thenTc_`
+ returnTc (mkTcTypeKind, ty')
+ )
+ where
+ (tyvar_names, kinds) = unzip tyvars_w_kinds
+ tyvars = zipWithEqual mk_tyvar tyvar_names kinds
+ tc_kinds = map kindToTcKind kinds
+ mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
+
+-- for unfoldings only:
+tcMonoTypeKind (MonoDictTy class_name ty)
+ = tcMonoTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
+ tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
+ unifyKind class_kind arg_kind `thenTc_`
+ returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
+
+
+tc_mono_name :: Name -> NF_TcM s (TcKind s, Type)
+tc_mono_name name@(Short _ _) -- Must be a type variable
+ = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+ returnNF_Tc (kind, mkTyVarTy tyvar)
+
+tc_mono_name name | isTyConName name -- Must be a type constructor
+ = tcLookupTyCon name `thenNF_Tc` \ (kind,tycon) ->
+ returnNF_Tc (kind, mkTyConTy tycon)
+
+tc_mono_name name -- Renamer should have got it right
+ = panic ("tc_mono_name:" ++ ppShow 1000 (ppr PprDebug name))
\end{code}
-@tcInstanceType@ checks the type {\em and} its syntactic constraints:
-it must normally look like: @instance Foo (Tycon a b c ...) ...@
-(We're checking the @Tycon a b c ...@ part here...)
-The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
-flag is on, or (2)~the instance is imported (they must have been
-compiled elsewhere). In these cases, we let them go through anyway.
+Contexts
+~~~~~~~~
+\begin{code}
+
+tcContext :: RenamedContext -> TcM s ThetaType
+tcContext context = mapTc tcClassAssertion context
+
+tcClassAssertion (class_name, tyvar_name)
+ = checkTc (canBeUsedInContext class_name)
+ (naughtyCCallContextErr class_name) `thenTc_`
+
+ tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
+ tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, tyvar) ->
-We can also have instances for functions: @instance Foo (a -> b) ...@.
+ unifyKind class_kind tyvar_kind `thenTc_`
+
+ returnTc (clas, mkTyVarTy tyvar)
+\end{code}
+
+HACK warning: Someone discovered that @_CCallable@ and @_CReturnable@
+could be used in contexts such as:
+\begin{verbatim}
+foo :: _CCallable a => a -> PrimIO Int
+\end{verbatim}
+
+Doing this utterly wrecks the whole point of introducing these
+classes so we specifically check that this isn't being done.
\begin{code}
-tcInstanceType :: CE -> TCE -> TVE
- -> Bool{-True <=> from this module-} -> SrcLoc
- -> RenamedMonoType
- -> Baby_TcM UniType
-
-tcInstanceType ce tce tve from_here locn mono_ty
- = tcMonoType ce tce tve mono_ty `thenB_Tc` \ tau_ty ->
- let
- (naughty, unkosher) = bad_shape tau_ty
- in
- getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr ->
- checkB_Tc
- (if not from_here || sw_chkr GlasgowExts then -- no "shape" checking
- naughty
- else
- naughty || unkosher
- )
- (instTypeErr tau_ty locn) `thenB_Tc_`
- returnB_Tc tau_ty
+canBeUsedInContext :: Name -> Bool
+canBeUsedInContext (ClassName uniq _ _) = not (uniq `elem` cCallishClassKeys)
+canBeUsedInContext other = True
+\end{code}
+
+
+Polytypes
+~~~~~~~~~
+\begin{code}
+tcPolyType :: RenamedPolyType -> TcM s Type
+tcPolyType (HsForAllTy tyvar_names context ty)
+ = tcTyVarScope tyvar_names (\ tyvars ->
+ tcContext context `thenTc` \ theta ->
+ tcMonoType ty `thenTc` \ tau ->
+ returnTc (mkSigmaTy tyvars theta tau)
+ )
+\end{code}
+
+Auxilliary functions
+~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+synArityCheck :: Name -> Int -> TcM s ()
+synArityCheck name n_args
+ = case getSynNameArity name of
+ Just arity | arity /= n_args -> failTc (err arity)
+ other -> returnTc ()
where
- -- "naughty" if the type is really unacceptable, no
- -- matter what (e.g., a type synonym); "unkosher" if
- -- the Haskell report forbids it, but we allow it through
- -- under -fglasgow-exts.
-
- bad_shape ty
- = if (is_syn_type ty) then
- (True, bottom)
- else case (getUniDataTyCon_maybe ty) of
- Just (_,tys,_) -> (False, not (all isTyVarTemplateTy tys))
- Nothing -> case maybeUnpackFunTy ty of
- Just (t1, t2) -> (False,
- not (all isTyVarTemplateTy [t1, t2]))
- Nothing -> (True, bottom)
- where
- bottom = panic "bad_shape"
-
- is_syn_type ty -- ToDo: move to AbsUniType (or friend)?
- = case ty of
- UniSyn _ _ _ -> True
- _ -> False
+ err arity = arityErr "Type synonym constructor" name arity n_args
+\end{code}
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+naughtyCCallContextErr clas_name sty
+ = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"]
\end{code}
+++ /dev/null
-% Filename: %M%
-% Version : %I%
-% Date : %G%
-%
-\section[TcParQuals]{TcParQuals}
-
-\begin{code}
-module TcParQuals ( tcParQuals , tcPidPats , tcPidExprs ) where
-
-#include "HsVersions.h"
-
-import TcMonad -- typechecking monad machinery
-import TcMonadFns
-import AbsSyn -- the stuff being typechecked
-
-import AbsPrel ( boolTy, mkProcessorTy, mkPodTy ,
- toDomainId, fromDomainId
- )
-import AbsUniType
-import Id ( mkInstId )
-import Inst ( InstOrigin(..) )
-import E
-import LIE
-import TcExpr ( tcExpr , tcExprs )
-import TcPat ( tcPat , tcPats )
-import Unify
-import Util
-\end{code}
-
-
-\begin{code}
-tcParQuals :: E -> RenamedParQuals -> TcM (TypecheckedParQuals,LIE)
-tcParQuals e (AndParQuals quals1 quals2)
- = (tcParQuals e quals1) `thenTc` (\ (quals1',lie1) ->
- (tcParQuals e quals2) `thenTc` (\ (quals2',lie2) ->
- returnTc (AndParQuals quals1' quals2', lie1 `plusLIE` lie2) ))
-
-tcParQuals e (ParFilter expr)
- = (tcExpr e expr) `thenTc` (\ (expr',lie,ty) ->
- (unifyTauTy ty boolTy (ParFilterCtxt expr)) `thenTc_`
- returnTc (ParFilter expr',lie) )
-
-tcParQuals e (DrawnGenIn pats pat expr)
- = (tcPidPats e pats) `thenTc` (\ (pats',convs,lie1,patsTy) ->
- (tcPat e pat) `thenTc` (\ (pat' ,patTy, lie2) ->
- (tcExpr e expr) `thenTc` (\ (expr',lie3,exprTy) ->
- (unifyTauTy exprTy
- (mkPodTy (mkProcessorTy patsTy patTy))
- (DrawnCtxt pats pat expr)) `thenTc_`
- returnTc (DrawnGenOut pats' convs pat' expr',
- plusLIE (plusLIE lie1 lie2) lie3 ) )))
-
-tcParQuals e (IndexGen exprs pat expr)
- = (tcPidExprs e exprs) `thenTc` (\ (exprs',lie1,exprsTy) ->
- (tcPat e pat) `thenTc` (\ (pat',patTy, lie2) ->
- (tcExpr e expr) `thenTc` (\ (expr',lie3,exprTy) ->
- (unifyTauTy exprTy
- (mkPodTy (mkProcessorTy exprsTy patTy))
- (IndexCtxt exprs pat expr)) `thenTc_`
- returnTc (IndexGen exprs' pat' expr',
- plusLIE (plusLIE lie1 lie2) lie3) )))
-
-\end{code}
-
-\begin{code}
-tcPidExprs:: E -> [RenamedExpr] -> TcM ([TypecheckedExpr],LIE,[TauType])
-tcPidExprs e exprs
- = tcExprs e exprs `thenTc` (\ (exprs',lie,tys)->
- getSrcLocTc `thenNF_Tc` (\ loc ->
- listNF_Tc (map (getFromDomain loc) tys) `thenNF_Tc` (\ fromDomains ->
- returnTc (zipWith mkConversion fromDomains exprs',
- mkLIE fromDomains `plusLIE` lie,tys)
- )))
- where
- getFromDomain loc ty
- = newMethod (OccurrenceOf toDomainId loc) fromDomainId [ty]
-
- mkConversion fromDom expr
- = App (Var (mkInstId fromDom)) expr
-\end{code}
-
-\begin{code}
-tcPidPats ::E ->[RenamedPat]->TcM ([TypecheckedPat], -- Expression
- [TypecheckedExpr], -- Conversion fns
- LIE,
- [UniType])
-tcPidPats e pats
- = tcPats e pats `thenTc` (\ (pats',tys,lie)->
- getSrcLocTc `thenNF_Tc` (\ loc ->
- listNF_Tc (map (getToDomain loc) tys) `thenNF_Tc` (\ toDomains ->
- returnTc (pats',map mkConversion toDomains,
- mkLIE toDomains `plusLIE` lie,tys)
- )))
- where
- getToDomain loc ty= newMethod (OccurrenceOf toDomainId loc) toDomainId [ty]
- mkConversion toDom= Var (mkInstId toDom)
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcPat where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsPat(InPat, TypecheckedPat)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcPat :: E -> InPat Name -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (TypecheckedPat, LIE, UniType)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcPat]{Typechecking patterns}
\begin{code}
#include "HsVersions.h"
-module TcPat (
- tcPat
-#ifdef DPH
- , tcPats
-#endif
- ) where
-
-import TcMonad -- typechecking monad machinery
-import TcMonadFns ( newOpenTyVarTy, newPolyTyVarTy,
- newPolyTyVarTys, copyTyVars, newMethod,
- newOverloadedLit
- )
-import AbsSyn -- the stuff being typechecked
-
-import AbsPrel ( charPrimTy, intPrimTy, floatPrimTy,
+module TcPat ( tcPat ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
+ Match, HsBinds, Qual, PolyType,
+ ArithSeqInfo, Stmt, Fake )
+import RnHsSyn ( RenamedPat(..) )
+import TcHsSyn ( TcPat(..), TcIdOcc(..) )
+
+import TcMonad
+import Inst ( Inst, OverloadedLit(..), InstOrigin(..), LIE(..),
+ emptyLIE, plusLIE, newMethod, newOverloadedLit )
+import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
+ tcLookupLocalValueOK )
+import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
+import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
+
+import Bag ( Bag )
+import CmdLineOpts ( opt_IrrefutableTuples )
+import ErrUtils ( arityErr )
+import Id ( GenId, idType )
+import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
+import Name ( Name )
+import PprType ( GenType, GenTyVar )
+import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, charTy, stringTy, mkListTy,
- mkTupleTy, addrTy, addrPrimTy, --OLD: eqStringId
- PrimOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-#ifdef DPH
- ,mkProcessorTy, toDomainId
-#endif {- Data Parallel Haskell -}
- )
-import AbsUniType ( instantiateTauTy, applyTyCon, InstTyEnv(..)
- IF_ATTACK_PRAGMAS(COMMA instantiateTy)
- )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( mkInstId, getIdUniType, getDataConSig,
- getInstantiatedDataConSig, Id, DataCon(..)
- )
-import Inst
-import E ( lookupE_Binder, lookupE_Value,
- lookupE_ClassOpByKey, E,
- LVE(..), TCE(..), UniqFM, CE(..)
- -- TCE and CE for pragmas only
- )
-import Errors ( dataConArityErr, Error(..), UnifyErrContext(..)
- )
-import LIE ( nullLIE, plusLIE, mkLIE, LIE )
-import Unify
-import Unique -- some ClassKey stuff
-import Util
-
-#ifdef DPH
-import TcParQuals
-#endif {- Data Parallel Haskell -}
-\end{code}
+ mkTupleTy, addrTy, addrPrimTy )
+import Pretty
+import Type ( Type(..), GenType, splitFunTy, splitSigmaTy )
+import TyVar ( GenTyVar )
+import Unique ( Unique, eqClassOpKey )
-The E passed in already contains bindings for all the variables in
-the pattern, usually to fresh type variables (but maybe not, if there
-were type signatures present).
+\end{code}
\begin{code}
-tcPat :: E -> RenamedPat -> TcM (TypecheckedPat, LIE, UniType)
+tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcPat e (VarPatIn name)
- = let
- id = lookupE_Binder e name
- in
- returnTc (VarPat id, nullLIE, getIdUniType id)
+tcPat (VarPatIn name)
+ = tcLookupLocalValueOK "tcPat1" name `thenNF_Tc` \ id ->
+ returnTc (VarPat (TcId id), emptyLIE, idType id)
-tcPat e (LazyPatIn pat)
- = tcPat e pat `thenTc` \ (pat', lie, ty) ->
+tcPat (LazyPatIn pat)
+ = tcPat pat `thenTc` \ (pat', lie, ty) ->
returnTc (LazyPat pat', lie, ty)
-tcPat e pat_in@(AsPatIn name pat)
- = let
- id = lookupE_Binder e name
- in
- tcPat e pat `thenTc` \ (pat', lie, ty) ->
- unifyTauTy (getIdUniType id) ty (PatCtxt pat_in) `thenTc_`
- returnTc (AsPat id pat', lie, ty)
+tcPat pat_in@(AsPatIn name pat)
+ = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id ->
+ tcPat pat `thenTc` \ (pat', lie, ty) ->
+ tcAddErrCtxt (patCtxt pat_in) $
+ unifyTauTy (idType id) ty `thenTc_`
+ returnTc (AsPat (TcId id) pat', lie, ty)
-tcPat e (WildPatIn)
- = newOpenTyVarTy `thenNF_Tc` \ tyvar_ty ->
- returnTc (WildPat tyvar_ty, nullLIE, tyvar_ty)
+tcPat (WildPatIn)
+ = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
+ returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcPat e pat_in@(ListPatIn pats)
- = tcPats e pats `thenTc` \ (pats', lie, tys) ->
- newPolyTyVarTy `thenNF_Tc` \ tyvar_ty ->
-
- unifyTauTyList (tyvar_ty:tys) (PatCtxt pat_in) `thenTc_`
+tcPat pat_in@(ListPatIn pats)
+ = tcPats pats `thenTc` \ (pats', lie, tys) ->
+ newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
+ tcAddErrCtxt (patCtxt pat_in) $
+ unifyTauTyList (tyvar_ty:tys) `thenTc_`
returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
-tcPat e pat_in@(TuplePatIn pats)
+tcPat pat_in@(TuplePatIn pats)
= let
arity = length pats
in
- tcPats e pats `thenTc` \ (pats', lie, tys) ->
+ tcPats pats `thenTc` \ (pats', lie, tys) ->
- -- We have to unify with fresh polymorphic type variables, to
- -- make sure we record that the tuples can only contain boxed
- -- types.
- newPolyTyVarTys arity `thenNF_Tc` \ tyvar_tys ->
+ -- Make sure we record that the tuples can only contain boxed types
+ newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys ->
- unifyTauTyLists tyvar_tys tys (PatCtxt pat_in) `thenTc_`
+ tcAddErrCtxt (patCtxt pat_in) $
+ unifyTauTyLists tyvar_tys tys `thenTc_`
-- possibly do the "make all tuple-pats irrefutable" test:
- getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
let
unmangled_result = TuplePat pats'
-- so that we can experiment with lazy tuple-matching.
-- This is a pretty odd place to make the switch, but
-- it was easy to do.
+
possibly_mangled_result
- = if sw_chkr IrrefutableTuples
+ = if opt_IrrefutableTuples
then LazyPat unmangled_result
else unmangled_result
efficient?
\begin{code}
-tcPat e pat_in@(ConPatIn name pats)
- = let
- con_id = lookupE_Value e name
- in
- tcPats e pats `thenTc` \ (pats', lie, tys) ->
+tcPat pat_in@(ConPatIn name pats)
+ = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
- matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty ->
+ tcPats pats `thenTc` \ (pats', lie, tys) ->
- returnTc (ConPat con_id data_ty pats', lie, data_ty)
+ tcAddErrCtxt (patCtxt pat_in) $
+ matchConArgTys con_id tys `thenTc` \ data_ty ->
-tcPat e pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
- = let
- con_id = lookupE_Value e op
- in
- tcPats e [pat1, pat2] `thenTc` \ ([pat1',pat2'], lie, tys) ->
- -- ToDo: there exists a less ugly way, no doubt...
+ returnTc (ConPat con_id data_ty pats',
+ lie,
+ data_ty)
+
+tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
+ = tcLookupGlobalValue op `thenNF_Tc` \ con_id ->
- matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty ->
+ tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
+ tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
- returnTc (ConOpPat pat1' con_id pat2' data_ty, lie, data_ty)
+ tcAddErrCtxt (patCtxt pat_in) $
+ matchConArgTys con_id [ty1,ty2] `thenTc` \ data_ty ->
+
+ returnTc (ConOpPat pat1' con_id pat2' data_ty,
+ lie1 `plusLIE` lie2,
+ data_ty)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcPat e (LitPatIn lit@(CharLit str))
- = returnTc (LitPat lit charTy, nullLIE, charTy)
+tcPat (LitPatIn lit@(HsChar str))
+ = returnTc (LitPat lit charTy, emptyLIE, charTy)
-tcPat e (LitPatIn lit@(StringLit str))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- let
- origin = LiteralOrigin lit loc
- eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==")
- in
- newMethod origin eq_id [stringTy] `thenNF_Tc` \ eq ->
+tcPat (LitPatIn lit@(HsString str))
+ = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
+ newMethod (LiteralOrigin lit)
+ (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
let
- comp_op = App (Var (mkInstId eq)) (Lit lit)
+ comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
in
- returnTc (NPat lit stringTy comp_op, mkLIE [eq], stringTy)
-
-{- OLD:
-tcPat e (LitPatIn lit@(StringLit str))
- = returnTc (NPat lit stringTy comp_op, nullLIE, stringTy)
- where
- comp_op = App (Var eqStringId) (Lit lit)
--}
-
-tcPat e (LitPatIn lit@(IntPrimLit _))
- = returnTc (LitPat lit intPrimTy, nullLIE, intPrimTy)
-tcPat e (LitPatIn lit@(CharPrimLit _))
- = returnTc (LitPat lit charPrimTy, nullLIE, charPrimTy)
-tcPat e (LitPatIn lit@(StringPrimLit _))
- = returnTc (LitPat lit addrPrimTy, nullLIE, addrPrimTy)
-tcPat e (LitPatIn lit@(FloatPrimLit _))
- = returnTc (LitPat lit floatPrimTy, nullLIE, floatPrimTy)
-tcPat e (LitPatIn lit@(DoublePrimLit _))
- = returnTc (LitPat lit doublePrimTy, nullLIE, doublePrimTy)
+ returnTc (NPat lit stringTy comp_op, lie, stringTy)
+
+tcPat (LitPatIn lit@(HsIntPrim _))
+ = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
+tcPat (LitPatIn lit@(HsCharPrim _))
+ = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
+tcPat (LitPatIn lit@(HsStringPrim _))
+ = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
+tcPat (LitPatIn lit@(HsFloatPrim _))
+ = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
+tcPat (LitPatIn lit@(HsDoublePrim _))
+ = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcPat e (LitPatIn lit@(IntLit i))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- let
- origin = LiteralOrigin lit loc
- in
- newPolyTyVarTy `thenNF_Tc` \ tyvar_ty ->
- let
- from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
- from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
- eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==")
- in
- newOverloadedLit origin
- (OverloadedIntegral i from_int from_integer)
- tyvar_ty `thenNF_Tc` \ over_lit ->
+tcPat (LitPatIn lit@(HsInt i))
+ = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
+ newOverloadedLit origin
+ (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
- newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq ->
+ tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
+ newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
- returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
- (Var (mkInstId over_lit))),
- mkLIE [over_lit, eq],
+ returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
+ (HsVar over_lit_id)),
+ lie1 `plusLIE` lie2,
tyvar_ty)
+ where
+ origin = LiteralOrigin lit
-tcPat e (LitPatIn lit@(FracLit f))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- let
- origin = LiteralOrigin lit loc
- in
- newPolyTyVarTy `thenNF_Tc` \ tyvar_ty ->
- let
- eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==")
- from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational")
- in
+tcPat (LitPatIn lit@(HsFrac f))
+ = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
newOverloadedLit origin
- (OverloadedFractional f from_rational)
- tyvar_ty `thenNF_Tc` \ over_lit ->
+ (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
- newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq ->
+ tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
+ newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
- returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
- (Var (mkInstId over_lit))),
- mkLIE [over_lit, eq],
+ returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
+ (HsVar over_lit_id)),
+ lie1 `plusLIE` lie2,
tyvar_ty)
+ where
+ origin = LiteralOrigin lit
-tcPat e (LitPatIn lit@(LitLitLitIn s))
+tcPat (LitPatIn lit@(HsLitLit s))
= error "tcPat: can't handle ``literal-literal'' patterns"
-{-
- = getSrcLocTc `thenNF_Tc` \ loc ->
- let
- origin = LiteralOrigin lit loc
- in
- newPolyTyVarTy `thenNF_Tc` \ tyvar_ty ->
- let
- eq_id = lookupE_ClassOpByKey e eqClassKey "=="
- in
- newOverloadedLit origin
- (OverloadedLitLit s)
- tyvar_ty `thenNF_Tc` \ over_lit ->
-
- newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq ->
-
- returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
- (Var (mkInstId over_lit))),
- mkLIE [over_lit, eq],
- tyvar_ty)
--}
-
-tcPat e (NPlusKPatIn name lit@(IntLit k))
- = getSrcLocTc `thenNF_Tc` \ loc ->
- let
- origin = LiteralOrigin lit loc
-
- local = lookupE_Binder e name
- local_ty = getIdUniType local
-
- ge_id = lookupE_ClassOpByKey e ordClassKey SLIT(">=")
- minus_id = lookupE_ClassOpByKey e numClassKey SLIT("-")
- from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
- from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
- in
- newOverloadedLit origin
- (OverloadedIntegral k from_int from_integer)
- local_ty `thenNF_Tc` \ over_lit ->
-
- newMethod origin ge_id [local_ty] `thenNF_Tc` \ ge ->
- newMethod origin minus_id [local_ty] `thenNF_Tc` \ minus ->
-
- returnTc (NPlusKPat local lit local_ty
- (Var (mkInstId over_lit))
- (Var (mkInstId ge))
- (Var (mkInstId minus)),
- mkLIE [over_lit, ge, minus],
- local_ty)
-
-tcPat e (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an IntLit"
-
-#ifdef DPH
-tcPat e (ProcessorPatIn pats pat)
- = tcPidPats e pats `thenTc` \ (pats',convs, lie, tys)->
- tcPat e pat `thenTc` \ (pat', ty, lie') ->
- returnTc (ProcessorPat pats' convs pat',
- plusLIE lie lie',
- mkProcessorTy tys ty)
-#endif {- Data Parallel Haskell -}
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcPats :: E -> [RenamedPat] -> TcM ([TypecheckedPat], LIE, [UniType])
+tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
-tcPats e [] = returnTc ([], nullLIE, [])
+tcPats [] = returnTc ([], emptyLIE, [])
-tcPats e (pat:pats)
- = tcPat e pat `thenTc` \ (pat', lie, ty) ->
- tcPats e pats `thenTc` \ (pats', lie', tys) ->
+tcPats (pat:pats)
+ = tcPat pat `thenTc` \ (pat', lie, ty) ->
+ tcPats pats `thenTc` \ (pats', lie', tys) ->
returnTc (pat':pats', plusLIE lie lie', ty:tys)
\end{code}
unifies the actual args against the expected ones.
\begin{code}
-matchConArgTys :: Id -> [UniType] -> (UniType -> UnifyErrContext) -> TcM UniType
+matchConArgTys :: Id -> [TcType s] -> TcM s (TcType s)
-matchConArgTys con_id arg_tys err_ctxt
- = let
+matchConArgTys con_id arg_tys
+ = tcInstType [] (idType con_id) `thenNF_Tc` \ con_ty ->
+ let
no_of_args = length arg_tys
- (sig_tyvars, sig_theta, sig_tys, _) = getDataConSig con_id
+ (con_tyvars, con_theta, con_tau) = splitSigmaTy con_ty
-- Ignore the sig_theta; overloaded constructors only
-- behave differently when called, not when used for
-- matching.
- con_arity = length sig_tys
+ (con_args, con_result) = splitFunTy con_tau
+ con_arity = length con_args
in
- getSrcLocTc `thenNF_Tc` \ loc ->
- checkTc (con_arity /= no_of_args)
- (dataConArityErr con_id con_arity no_of_args loc) `thenTc_`
+ checkTc (con_arity == no_of_args)
+ (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
- copyTyVars sig_tyvars `thenNF_Tc` \ (inst_env, _, new_tyvar_tys) ->
- let
- (_,inst_arg_tys,inst_result_ty) = getInstantiatedDataConSig con_id new_tyvar_tys
- in
- unifyTauTyLists arg_tys inst_arg_tys (err_ctxt inst_result_ty) `thenTc_`
- returnTc inst_result_ty
+ unifyTauTyLists arg_tys con_args `thenTc_`
+ returnTc con_result
+\end{code}
+
+
+% =================================================
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcPolyType where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import HsTypes(PolyType)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcPolyType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> PolyType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[TcPolyType]{Typechecking user-specified @PolyTypes@}
-
-\begin{code}
-module TcPolyType ( tcPolyType ) where
-
-#include "HsVersions.h"
-
-import TcMonad -- typechecking monad machinery
-import AbsSyn -- the stuff being typechecked
-
-import AbsUniType ( mkTyVarTemplateTy, mkSysTyVarTemplate, mkSigmaTy,
- mkForallTy, SigmaType(..)
- )
-import CE ( CE(..) )
-import Maybes ( Maybe(..) )
-import TCE ( TCE(..), UniqFM )
-import TVE -- ( mkTVE, plusTVE, unitTVE, lookupTVE_NoFail, TVE(..) )
-import TcContext ( tcContext )
-import TcMonoType ( tcMonoType )
-import Util
-\end{code}
-
-The TVE passed into @tcPolyType@ binds type variables which are
-in scope; in practice this is always either empty (ordinary type sigs)
-or a singleton (class signatures). @tcPolyType@ generates a type which
-is polymorphic in all the {\em other} type varaibles mentioned in the
-type.
-
-Very Important Note: when we have a type signature in an interface, say
-\begin{verbatim}
- f :: a -> b -> a
-\end{verbatim}
-which of the following polytypes do we return?
-\begin{verbatim}
- forall a b. a -> b -> a
---or
- forall b a. a -> b -> a
-\end{verbatim}
-
-It makes a difference, because it affects the order in which f takes
-its type arguments. Now this makes a difference in two ways:
-\begin{itemize}
-\item
-It's essential to get it right if an inlining for f is also exported
-by the interface.
-\item
-It's essential to get it right if the interface tells that there's a specialised
-version of f, because specialisations are known by their function-name/type-arg
-combinations.
-\end{itemize}
-
-By convention, the foralls on a type read in from somewhere (notably interfaces)
-are
- {\em in alphabetical order of their type variables}
-
-When printing types we make sure that we assign print-names to the forall'd type
-variables which are also in alphabetical order.
-
-\begin{code}
-tcPolyType :: CE -> TCE -> TVE -> RenamedPolyType -> Baby_TcM UniType
-
-tcPolyType ce tce tve (ForAllTy tvs ty)
- = let
- new_tv_tmpls_w_uniqs = map tc_uf_tyvar_template tvs
- new_tv_tmpls = map snd new_tv_tmpls_w_uniqs
- new_tve
- = foldr plusTVE tve
- [ unitTVE u (mkTyVarTemplateTy tv)
- | (u, tv) <- new_tv_tmpls_w_uniqs ]
- in
- tcMonoType ce tce new_tve ty `thenB_Tc` \ new_ty ->
- returnB_Tc (mkForallTy new_tv_tmpls new_ty)
- where
- tc_uf_tyvar_template (Short u _) = (u, mkSysTyVarTemplate u SLIT("a"))
-
-tcPolyType ce tce tve (OverloadedTy ctxt ty) = tc_poly ce tce tve ctxt ty
-tcPolyType ce tce tve (UnoverloadedTy ty) = tc_poly ce tce tve [] ty
-
-tc_poly ce tce tve ctxt ty
- = let -- BUILD THE NEW TVE
- used_tyvar_names = extractMonoTyNames (==) ty
- poly_tyvar_names = drop_tyvars_if_in_TVE used_tyvar_names
-
- -- Sort them into alphabetical order; see notes above.
- sorted_tyvar_names = sortLt lt_by_string poly_tyvar_names
-
- (local_tve, tyvars, _) = mkTVE sorted_tyvar_names
- new_tve = plusTVE tve local_tve
- in
- -- TYPE CHECK THE CONTEXT AND MONOTYPE
- tcContext ce tce new_tve ctxt `thenB_Tc` \ theta ->
- tcMonoType ce tce new_tve ty `thenB_Tc` \ tau_ty ->
-
- -- BUILD THE POLYTYPE AND RETURN
- returnB_Tc (mkSigmaTy tyvars theta tau_ty)
- where
- drop_tyvars_if_in_TVE [] = []
- drop_tyvars_if_in_TVE (n:ns)
- = let rest = drop_tyvars_if_in_TVE ns
- in
- case (lookupTVE_NoFail tve n) of
- Just _ -> rest -- drop it
- Nothing -> n : rest
-
- lt_by_string :: Name -> Name -> Bool
- lt_by_string a b = getOccurrenceName a < getOccurrenceName b
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcPragmas where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsDecls(ConDecl)
-import HsPragmas(ClassOpPragmas, DataPragmas, GenPragmas, InstancePragmas, TypePragmas)
-import Id(Id)
-import IdInfo(IdInfo, SpecEnv, SpecInfo)
-import Maybes(Labda)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcClassOpPragmas :: E -> UniType -> Id -> Id -> SpecEnv -> ClassOpPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (IdInfo, IdInfo)
-tcDataPragmas :: UniqFM TyCon -> UniqFM UniType -> TyCon -> [TyVarTemplate] -> DataPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ([ConDecl Name], [SpecInfo])
-tcDictFunPragmas :: E -> UniType -> Id -> InstancePragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult IdInfo
-tcGenPragmas :: E -> Labda UniType -> Id -> GenPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult IdInfo
-tcTypePragmas :: TypePragmas -> Bool
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[TcPragmas]{Typecheck ``pragmas'' of various kinds}
tcClassOpPragmas,
tcDataPragmas,
tcDictFunPragmas,
- tcGenPragmas,
- tcTypePragmas
+ tcGenPragmas
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-import Outputable
-
import TcMonad -- typechecking monadic machinery
-import TcMonadFns ( mkIdsWithGivenTys )
-import AbsSyn -- the stuff being typechecked
+import HsSyn -- the stuff being typechecked
-import AbsPrel ( PrimOp(..) -- to see CCallOp
+import PrelInfo ( PrimOp(..) -- to see CCallOp
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType
-import CE ( lookupCE, nullCE, CE(..) )
+import Type
import CmdLineOpts
import CostCentre
-import E
-import Errors
import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
import Id
import IdInfo
-import WwLib ( mkWwBodies )
-import InstEnv ( lookupClassInstAtSimpleType )
+--import WwLib ( mkWwBodies )
import Maybes ( assocMaybe, catMaybes, Maybe(..) )
-import CoreLint ( lintUnfolding )
-import PlainCore
-import TCE ( TCE(..), UniqFM )
-import TVE
-import TcMonoType ( tcMonoType )
-import TcPolyType ( tcPolyType )
+--import CoreLint ( lintUnfolding )
+import TcMonoType ( tcMonoType, tcPolyType )
import Util
import SrcLoc
\end{code}
\begin{code}
tcClassOpPragmas :: E -- Class/TyCon lookup tables
- -> UniType -- global type of the class method
+ -> Type -- global type of the class method
-> Id -- *final* ClassOpId
-> Id -- *final* DefaultMethodId
-> SpecEnv -- Instance info for this class op
= returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo)
tcClassOpPragmas e global_ty
- rec_classop_id rec_defm_id
+ rec_classop_id rec_defm_id
spec_infos
(ClassOpPragmas classop_pragmas defm_pragmas)
= tcGenPragmas e
\begin{code}
tcDictFunPragmas
:: E -- Class/TyCon lookup tables
- -> UniType -- DictFunId type
+ -> Type -- DictFunId type
-> Id -- final DictFunId (don't touch)
-> RenamedInstancePragmas -- info w/ which to complete, giving...
-> Baby_TcM IdInfo -- ... final DictFun IdInfo
\begin{code}
tcGenPragmas
:: E -- lookup table
- -> Maybe UniType -- of Id, if we have it (for convenience)
+ -> Maybe Type -- of Id, if we have it (for convenience)
-> Id -- *incomplete* Id (do not *touch*!)
-> RenamedGenPragmas -- info w/ which to complete, giving...
-> Baby_TcM IdInfo -- IdInfo for this Id
-- Same as unfolding; if we fail, don't junk all IdInfo
recoverIgnoreErrorsB_Tc nullSpecEnv (
tc_specs e rec_final_id ty_maybe specs
- ) `thenB_Tc` \ spec_env ->
+ ) `thenB_Tc` \ spec_env ->
returnB_Tc (
noIdInfo
\begin{code}
tc_strictness
:: E
- -> Maybe UniType
+ -> Maybe Type
-> Id -- final Id (do not *touch*)
-> ImpStrictness Name
-> Baby_TcM (StrictnessInfo, UnfoldingDetails)
-- go wrong if there's an abstract type involved, mind you.
let
(tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty
- n_wrapper_args = length wrap_arg_info
- -- Don't have more args than this, else you risk
+ n_wrapper_args = length wrap_arg_info
+ -- Don't have more args than this, else you risk
-- losing laziness!!
in
getUniquesB_Tc (length tv_tmpls) `thenB_Tc` \ tyvar_uniqs ->
getUniquesB_Tc n_wrapper_args `thenB_Tc` \ arg_uniqs ->
-
+
let
- (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
+ (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs
inst_arg_tys = map (instantiateTy inst_env) arg_tys
(undropped_inst_arg_tys, dropped_inst_arg_tys)
inst_ret_ty = glueTyArgs dropped_inst_arg_tys
(instantiateTy inst_env ret_ty)
- args = zipWith mk_arg arg_uniqs undropped_inst_arg_tys
+ args = zipWithEqual mk_arg arg_uniqs undropped_inst_arg_tys
mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc
-- ASSERT: length args = n_wrapper_args
in
Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
- let
+ let
worker_ty = worker_ty_w_hole inst_ret_ty
in
getUniqueB_Tc `thenB_Tc` \ uniq ->
wrapper_rhs = wrapper_w_hole worker_id
n_tyvars = length tyvars
arity = length args
-
+
in
returnB_Tc (
mkStrictnessInfo wrap_arg_info (Just worker_id),
\begin{code}
tc_specs :: E
-> Id -- final Id for which these are specialisations (do not *touch*)
- -> Maybe UniType
+ -> Maybe Type
-> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)]
-> Baby_TcM SpecEnv
returnB_Tc (mkSpecEnv spec_infos)
where
(main_tyvars, _) = splitForalls main_ty
-
+
rec_ce = getE_CE e
rec_tce = getE_TCE e
(badSpecialisationErr "value" "wrong number of specialising types"
(length main_tyvars) maybe_tys locn)
`thenB_Tc_`
- let
+ let
spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore
in
fixB_Tc ( \ rec_spec_id ->
(lint_guidance, lint_expr) = case maybe_lint_expr of
Just lint_expr -> (guidance, lint_expr)
- Nothing -> (BadUnfolding, panic_expr)
+ Nothing -> (BadUnfolding, panic_expr)
in
returnB_Tc (mkUnfolding lint_guidance lint_expr)
where
-- (others: we hope we can figure them out)
-> TVE -- lookup table for tyvars
-> UnfoldingCoreExpr Name
- -> Baby_TcM PlainCoreExpr
+ -> Baby_TcM CoreExpr
- tc_uf_core lve tve (UfCoVar v)
+ tc_uf_core lve tve (UfVar v)
= tc_uf_Id lve v `thenB_Tc` \ id ->
- returnB_Tc (CoVar id)
+ returnB_Tc (Var id)
- tc_uf_core lve tve (UfCoLit l)
- = returnB_Tc (CoLit l)
+ tc_uf_core lve tve (UfLit l)
+ = returnB_Tc (Lit l)
- tc_uf_core lve tve (UfCoCon con tys as)
+ tc_uf_core lve tve (UfCon con tys as)
= tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
- returnB_Tc (CoCon con_id core_tys core_atoms)
+ returnB_Tc (Con con_id core_tys core_atoms)
-- If a ccall, we have to patch in the types read from the pragma.
- tc_uf_core lve tve (UfCoPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
+ tc_uf_core lve tve (UfPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as)
= ASSERT(null app_tys)
mapB_Tc (tc_uf_type tve) arg_tys `thenB_Tc` \ core_arg_tys ->
- tc_uf_type tve res_ty `thenB_Tc` \ core_res_ty ->
- mapB_Tc (tc_uf_type tve) app_tys `thenB_Tc` \ core_app_tys ->
+ tc_uf_type tve res_ty `thenB_Tc` \ core_res_ty ->
+ mapB_Tc (tc_uf_type tve) app_tys `thenB_Tc` \ core_app_tys ->
mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
- returnB_Tc (CoPrim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
+ returnB_Tc (Prim (CCallOp str is_casm may_gc core_arg_tys core_res_ty)
core_app_tys core_atoms)
- tc_uf_core lve tve (UfCoPrim (UfOtherOp op) tys as)
+ tc_uf_core lve tve (UfPrim (UfOtherOp op) tys as)
= mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys ->
mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms ->
- returnB_Tc (CoPrim op core_tys core_atoms)
+ returnB_Tc (Prim op core_tys core_atoms)
- tc_uf_core lve tve (UfCoLam binders body)
- = tc_uf_binders tve binders `thenB_Tc` \ lve2 ->
+ tc_uf_core lve tve (UfLam binder body)
+ = tc_uf_binders tve [binder] `thenB_Tc` \ lve2 ->
let
- new_binders = map snd lve2
+ [new_binder] = map snd lve2
new_lve = lve2 `plusLVE` lve
in
tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoLam new_binders new_body)
-
- tc_uf_core lve tve (UfCoTyLam tv body)
- = let
- (new_tv, uniq, new_tv_ty) = tc_uf_tyvar tv
- new_tve = tve `plusTVE` (unitTVE uniq new_tv_ty)
- in
- tc_uf_core lve new_tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoTyLam new_tv new_body)
+ returnB_Tc (Lam new_binder new_body)
- tc_uf_core lve tve (UfCoApp fun arg)
+ tc_uf_core lve tve (UfApp fun arg)
= tc_uf_core lve tve fun `thenB_Tc` \ new_fun ->
- tc_uf_atom lve tve arg `thenB_Tc` \ new_arg ->
- returnB_Tc (CoApp new_fun new_arg)
-
- tc_uf_core lve tve (UfCoTyApp expr ty)
- = tc_uf_core lve tve expr `thenB_Tc` \ new_expr ->
- tc_uf_type tve ty `thenB_Tc` \ new_ty ->
- returnB_Tc (mkCoTyApp new_expr new_ty)
+ tc_uf_atom lve tve arg `thenB_Tc` \ new_arg ->
+ returnB_Tc (App new_fun new_arg)
- tc_uf_core lve tve (UfCoCase scrut alts)
+ tc_uf_core lve tve (UfCase scrut alts)
= tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut ->
tc_alts alts `thenB_Tc` \ new_alts ->
- returnB_Tc (CoCase new_scrut new_alts)
+ returnB_Tc (Case new_scrut new_alts)
where
tc_alts (UfCoAlgAlts alts deflt)
= mapB_Tc tc_alg_alt alts `thenB_Tc` \ new_alts ->
tc_deflt deflt `thenB_Tc` \ new_deflt ->
- returnB_Tc (CoAlgAlts new_alts new_deflt)
+ returnB_Tc (AlgAlts new_alts new_deflt)
where
tc_alg_alt (con, params, rhs)
= tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id ->
tc_alts (UfCoPrimAlts alts deflt)
= mapB_Tc tc_prim_alt alts `thenB_Tc` \ new_alts ->
tc_deflt deflt `thenB_Tc` \ new_deflt ->
- returnB_Tc (CoPrimAlts new_alts new_deflt)
+ returnB_Tc (PrimAlts new_alts new_deflt)
where
tc_prim_alt (lit, rhs)
= tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
returnB_Tc (lit, new_rhs)
- tc_deflt UfCoNoDefault = returnB_Tc CoNoDefault
+ tc_deflt UfCoNoDefault = returnB_Tc NoDefault
tc_deflt (UfCoBindDefault b rhs)
= tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
let
new_lve = lve2 `plusLVE` lve
in
tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs ->
- returnB_Tc (CoBindDefault new_b new_rhs)
+ returnB_Tc (BindDefault new_b new_rhs)
- tc_uf_core lve tve (UfCoLet (UfCoNonRec b rhs) body)
+ tc_uf_core lve tve (UfLet (UfCoNonRec b rhs) body)
= tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs ->
tc_uf_binders tve [b] `thenB_Tc` \ lve2 ->
let
new_lve = lve2 `plusLVE` lve
in
tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoLet (CoNonRec new_b new_rhs) new_body)
+ returnB_Tc (Let (NonRec new_b new_rhs) new_body)
- tc_uf_core lve tve (UfCoLet (UfCoRec pairs) body)
+ tc_uf_core lve tve (UfLet (UfCoRec pairs) body)
= let
(binders, rhss) = unzip pairs
in
in
mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss ->
tc_uf_core new_lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoLet (CoRec (new_binders `zip` new_rhss)) new_body)
+ returnB_Tc (Let (Rec (new_binders `zip` new_rhss)) new_body)
- tc_uf_core lve tve (UfCoSCC uf_cc body)
+ tc_uf_core lve tve (UfSCC uf_cc body)
= tc_uf_cc uf_cc `thenB_Tc` \ new_cc ->
tc_uf_core lve tve body `thenB_Tc` \ new_body ->
- returnB_Tc (CoSCC new_cc new_body)
+ returnB_Tc (SCC new_cc new_body)
where
tc_uf_cc (UfAutoCC id m g is_dupd is_caf)
= tc_uf_Id lve id `thenB_Tc` \ new_id ->
= tc_uf_Id lve id `thenB_Tc` \ new_id ->
returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC))
- tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
+ tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g))
- tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
- tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
+ tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d)
+ tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d)
--------
adjust is_caf is_dupd cc
---------------
tc_uf_atom lve tve (UfCoLitAtom l)
- = returnB_Tc (CoLitAtom l)
+ = returnB_Tc (LitArg l)
tc_uf_atom lve tve (UfCoVarAtom v)
= tc_uf_Id lve v `thenB_Tc` \ new_v ->
- returnB_Tc (CoVarAtom new_v)
+ returnB_Tc (VarArg new_v)
---------------
tc_uf_binders tve ids_and_tys
dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of
Just id -> id
Nothing -> pprPanic "tc_uf_Id:DictFunUfId:"
- (ppr PprDebug (UfCoVar uf_id))
+ (ppr PprDebug (UfVar uf_id))
-- The class and type are both
-- visible, so the instance should
-- jolly well be too!
= tc_uf_Id lve unspec `thenB_Tc` \ unspec_id ->
mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes
`thenB_Tc` \ maybe_tys ->
- let
+ let
spec_id = lookupSpecId unspec_id maybe_tys
in
returnB_Tc spec_id
tc_uf_Id lve (WorkerUfId unwrkr)
= tc_uf_Id lve unwrkr `thenB_Tc` \ unwrkr_id ->
- let
+ let
strictness_info = getIdStrictness unwrkr_id
in
if isLocallyDefined unwrkr_id
-- A locally defined value will not have any strictness info (yet),
-- so we can't extract the locally defined worker Id from it :-(
- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
+ pprTrace "WARNING: Discarded bad unfolding from interface:\n"
(ppCat [ppStr "Worker Id in unfolding is defined locally:",
ppr PprDebug unwrkr_id])
(failB_Tc (panic "tc_uf_Id:WorkerUfId: locally defined"))
= getClassOps clas !! (tag - 1)
---------------------------------------------------------------------
- tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM UniType
+ tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type
tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty
\end{code}
(length new_tyvars) maybe_tys locn)
`thenB_Tc_`
- returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[tcTypePragmas]{@type@ synonym pragmas}
-%* *
-%************************************************************************
-
-The purpose of a @type@ pragma is to say that the synonym's
-representation should not be used by the user.
-
-\begin{code}
-tcTypePragmas :: TypePragmas
- -> Bool -- True <=> abstract synonym, please
-
-tcTypePragmas NoTypePragmas = False
-tcTypePragmas AbstractTySynonym = True
+ returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId"))
\end{code}
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcQuals where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import HsExpr(Qual)
-import HsPat(InPat, TypecheckedPat)
-import Id(Id)
-import LIE(LIE)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-tcQuals :: E -> [Qual Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Qual Id TypecheckedPat], LIE)
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[TcQuals]{TcQuals}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TcQuals ( tcQuals ) where
-
-import TcMonad -- typechecking monad machinery
-import AbsSyn -- the stuff being typechecked
-
-import AbsPrel ( boolTy, mkListTy )
-import E ( E, TCE(..), UniqFM, CE(..) )
- -- TCE and CE for pragmas only
-import Errors ( UnifyErrContext(..) )
-import LIE ( LIE, plusLIE )
-import TcExpr ( tcExpr )
-import TcPat ( tcPat )
-import Unify ( unifyTauTy )
-import Util
-\end{code}
-
-There will be at least one @Qual@.
-
-\begin{code}
-tcQuals :: E -> [RenamedQual] -> TcM ([TypecheckedQual], LIE)
-
-tcQuals e [qual]
- = tcQual e qual `thenTc` \ (new_qual, lie) ->
- returnTc ([new_qual], lie)
-
-tcQuals e (qual:quals)
- = tcQual e qual `thenTc` \ (new_qual, lie1) ->
- tcQuals e quals `thenTc` \ (new_quals, lie2) ->
- returnTc (new_qual : new_quals, lie1 `plusLIE` lie2)
-
----
-
-tcQual e (FilterQual expr)
- = tcExpr e expr `thenTc` \ (expr', lie, ty) ->
- unifyTauTy ty boolTy (FilterCtxt expr) `thenTc_`
- returnTc (FilterQual expr', lie)
-
-tcQual e (GeneratorQual pat expr)
- = tcPat e pat `thenTc` \ (pat', lie_pat, pat_ty) ->
- tcExpr e expr `thenTc` \ (expr', lie_expr, expr_ty) ->
-
- unifyTauTy expr_ty (mkListTy pat_ty) (GeneratorCtxt pat expr) `thenTc_`
-
- returnTc (GeneratorQual pat' expr', lie_pat `plusLIE` lie_expr)
-\end{code}
-
-
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcSimplify where
-import Bag(Bag)
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import ErrsTc(UnifyErrContext)
-import HsBinds(MonoBinds)
-import HsExpr(Expr)
-import HsPat(TypecheckedPat)
-import Id(Id)
-import Inst(Inst, InstOrigin)
-import LIE(LIE)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import TyVar(TyVar)
-import UniType(UniType)
-bindInstsOfLocalFuns :: LIE -> [Id] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, MonoBinds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-tcSimplify :: Bool -> [TyVar] -> [TyVar] -> [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)], [Inst])
-tcSimplifyAndCheck :: Bool -> [TyVar] -> [TyVar] -> [Inst] -> [Inst] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)])
-tcSimplifyCheckThetas :: InstOrigin -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-tcSimplifyRank2 :: [TyVar] -> [Inst] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)])
-tcSimplifyThetas :: (Class -> UniType -> InstOrigin) -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [(Class, UniType)]
-tcSimplifyTop :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [(Inst, Expr Id TypecheckedPat)]
-
#include "HsVersions.h"
module TcSimplify (
- tcSimplify, tcSimplifyAndCheck,
+ tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals,
tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
bindInstsOfLocalFuns
) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Outputable
+import Ubiq
+
+import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
+ Match, HsBinds, Qual, PolyType, ArithSeqInfo,
+ GRHSsAndBinds, Stmt, Fake )
+import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
+
+import TcMonad
+import Inst ( lookupInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst,
+ instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc,
+ Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE,
+ InstOrigin(..), OverloadedLit )
+import TcEnv ( tcGetGlobalTyVars )
+import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType )
+import Unify ( unifyTauTy )
+
+import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
+ snocBag, consBag, unionBags, isEmptyBag )
+import Class ( isNumericClass, isStandardClass, isCcallishClass,
+ isSuperClassOf, getSuperDictSelId )
+import Id ( GenId )
+import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) )
+import Outputable ( Outputable(..) )
+import PprType ( GenType, GenTyVar )
import Pretty
-
-import TcMonad -- typechecking monadic machinery
-import TcMonadFns ( newDicts, applyTcSubstAndExpectTyVars )
-import AbsSyn -- the stuff being typechecked
-
-import AbsUniType ( isSuperClassOf, getTyVar, eqTyVar, ltTyVar,
- instantiateThetaTy, isFunType, getUniDataTyCon,
- getSuperDictSelId, InstTyEnv(..)
- IF_ATTACK_PRAGMAS(COMMA isTyVarTy COMMA pprUniType)
- IF_ATTACK_PRAGMAS(COMMA assocMaybe)
- )
-import UniType ( UniType(..) ) -- ******* CHEATING ************
-import Disambig ( disambiguateDicts )
-import Errors ( reduceErr, genCantGenErr, Error(..) )
-import Id ( mkInstId )
-import Inst ( extractTyVarsFromInst, isTyVarDict, matchesInst,
- instBindingRequired, instCanBeGeneralised,
- Inst(..), -- We import the CONCRETE type, because
- -- TcSimplify is allowed to see the rep
- -- of Insts
- InstOrigin, OverloadedLit, InstTemplate
- )
-import InstEnv
-import LIE
-import ListSetOps ( minusList )
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
+import SrcLoc ( mkUnknownSrcLoc )
import Util
+import Type ( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy )
+import TysWiredIn ( intTy )
+import TyVar ( GenTyVar, GenTyVarSet(..),
+ elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
+ isEmptyTyVarSet, tyVarSetToList )
+import Unique ( Unique )
\end{code}
\begin{code}
-tcSimpl :: Bool -- True <=> Don't simplify const insts
- -> [TyVar] -- ``Global'' type variables
- -> [TyVar] -- ``Local'' type variables
- -> [Inst] -- Given; these constrain only local tyvars
- -> [Inst] -- Wanted
- -> TcM ([Inst], -- Free
- [(Inst,TypecheckedExpr)],-- Bindings
- [Inst]) -- Remaining wanteds; no dups
-
-tcSimpl dont_squash_consts global_tvs local_tvs givens wanteds
- =
- -- Make sure the insts and type variables are fixed points of the substitution
- applyTcSubstAndExpectTyVars global_tvs `thenNF_Tc` \ global_tvs ->
- applyTcSubstAndExpectTyVars local_tvs `thenNF_Tc` \ local_tvs ->
- applyTcSubstToInsts givens `thenNF_Tc` \ givens ->
- applyTcSubstToInsts wanteds `thenNF_Tc` \ wanteds ->
- let
- is_elem1 = isIn "tcSimpl1"
- is_elem2 = isIn "tcSimpl2"
- in
+tcSimpl :: Bool -- True <=> simplify const insts
+ -> TcTyVarSet s -- ``Global'' type variables
+ -> TcTyVarSet s -- ``Local'' type variables
+ -- ASSERT: both these tyvar sets are already zonked
+ -> LIE s -- Given; these constrain only local tyvars
+ -> LIE s -- Wanted
+ -> TcM s (LIE s, -- Free
+ [(TcIdOcc s,TcExpr s)], -- Bindings
+ LIE s) -- Remaining wanteds; no dups
+
+tcSimpl squash_consts global_tvs local_tvs givens wanteds
+ = -- ASSSERT: global_tvs and local_tvs are already zonked
+ -- Make sure the insts fixed points of the substitution
+ zonkLIE givens `thenNF_Tc` \ givens ->
+ zonkLIE wanteds `thenNF_Tc` \ wanteds ->
+
-- Deal with duplicates and type constructors
elimTyCons
- dont_squash_consts (\tv -> tv `is_elem1` global_tvs)
+ squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
givens wanteds `thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->
- -- Now disambiguate if necessary
+ -- Now disambiguate if necessary
let
- (ambigs, unambigs) = partition (is_ambiguous local_tvs) locals_and_ambigs
- (locals, cant_generalise) = partition instCanBeGeneralised unambigs
+ ambigs = filterBag is_ambiguous locals_and_ambigs
in
- checkTc (not (null cant_generalise)) (genCantGenErr cant_generalise) `thenTc_`
-
- (if (null ambigs) then
-
- -- No ambiguous dictionaries. Just bash on with the results
- -- of the elimTyCons
- returnTc (globals, tycon_binds, locals_and_ambigs)
-
- else
-
+ if not (isEmptyBag ambigs) then
-- Some ambiguous dictionaries. We now disambiguate them,
-- which binds the offending type variables to suitable types in the
-- substitution, and then we retry the whole process. This
-- to a particular type might enable a short-cut simplification which
-- elimTyCons will have missed the first time.
- disambiguateDicts ambigs `thenTc_`
- applyTcSubstToInsts givens `thenNF_Tc` \ givens ->
- applyTcSubstToInsts wanteds `thenNF_Tc` \ wanteds ->
- elimTyCons
- dont_squash_consts (\tv -> tv `is_elem2` global_tvs)
- givens wanteds
+ disambiguateDicts ambigs `thenTc_`
+ tcSimpl squash_consts global_tvs local_tvs givens wanteds
+
+ else
+ -- No ambiguous dictionaries. Just bash on with the results
+ -- of the elimTyCons
+
+ -- Check for non-generalisable insts
+ let
+ locals = locals_and_ambigs -- ambigs is empty
+ cant_generalise = filterBag (not . instCanBeGeneralised) locals
+ in
+ checkTc (isEmptyBag cant_generalise)
+ (genCantGenErr cant_generalise) `thenTc_`
- ) {- End of the "if" -} `thenTc` \ (globals, tycon_binds, locals) ->
-- Deal with superclass relationships
elimSCs givens locals `thenNF_Tc` \ (sc_binds, locals2) ->
-- Finished
- returnTc (globals, sc_binds ++ tycon_binds, locals2)
+ returnTc (globals, bagToList (sc_binds `unionBags` tycon_binds), locals2)
where
- is_ambiguous local_tvs (Dict _ _ ty _)
- = getTyVar "is_ambiguous" ty `not_elem` local_tvs
- where
- not_elem = isn'tIn "is_ambiguous"
+ is_ambiguous (Dict _ _ ty _ _)
+ = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
\end{code}
The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with
\begin{code}
tcSimplify
- :: Bool -- True <=> top level
- -> [TyVar] -- ``Global'' type variables
- -> [TyVar] -- ``Local'' type variables
- -> [Inst] -- Wanted
- -> TcM ([Inst], -- Free
- [(Inst, TypecheckedExpr)],-- Bindings
- [Inst]) -- Remaining wanteds; no dups
-
-tcSimplify top_level global_tvs local_tvs wanteds
- = tcSimpl (not top_level) global_tvs local_tvs [] wanteds
+ :: TcTyVarSet s -- ``Local'' type variables
+ -> LIE s -- Wanted
+ -> TcM s (LIE s, -- Free
+ [(TcIdOcc s,TcExpr s)], -- Bindings
+ LIE s) -- Remaining wanteds; no dups
+
+tcSimplify local_tvs wanteds
+ = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
+ tcSimpl False global_tvs local_tvs emptyBag wanteds
\end{code}
-@tcSimplifyAndCheck@ is similar to the above, except that it checks
-that there is an empty wanted-set at the end.
+@tcSimplifyWithExtraGlobals@ is just like @tcSimplify@ except that you get
+to specify some extra global type variables that the simplifer will treat
+as free in the environment.
-It may still return some of constant insts, which have
-to be resolved finally at the end.
+\begin{code}
+tcSimplifyWithExtraGlobals
+ :: TcTyVarSet s -- Extra ``Global'' type variables
+ -> TcTyVarSet s -- ``Local'' type variables
+ -> LIE s -- Wanted
+ -> TcM s (LIE s, -- Free
+ [(TcIdOcc s,TcExpr s)], -- Bindings
+ LIE s) -- Remaining wanteds; no dups
+
+tcSimplifyWithExtraGlobals extra_global_tvs local_tvs wanteds
+ = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
+ tcSimpl False
+ (global_tvs `unionTyVarSets` extra_global_tvs)
+ local_tvs emptyBag wanteds
+\end{code}
+
+@tcSimplifyAndCheck@ is similar to the above, except that it checks
+that there is an empty wanted-set at the end. It may still return
+some of constant insts, which have to be resolved finally at the end.
\begin{code}
tcSimplifyAndCheck
- :: Bool -- True <=> top level
- -> [TyVar] -- ``Global'' type variables
- -> [TyVar] -- ``Local'' type variables
- -> [Inst] -- Given
- -> [Inst] -- Wanted
- -> UnifyErrContext -- Context info for error
- -> TcM ([Inst], -- Free
- [(Inst, TypecheckedExpr)]) -- Bindings
-
-tcSimplifyAndCheck top_level global_tvs local_tvs givens wanteds err_ctxt
- = tcSimpl (not top_level) global_tvs local_tvs givens wanteds
- `thenTc` \ (free_insts, binds, wanteds') ->
- checkTc (not (null wanteds')) (reduceErr wanteds' err_ctxt)
- `thenTc_`
+ :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
+ -> LIE s -- Given
+ -> LIE s -- Wanted
+ -> TcM s (LIE s, -- Free
+ [(TcIdOcc s,TcExpr s)]) -- Bindings
+
+tcSimplifyAndCheck local_tvs givens wanteds
+ = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
+ tcSimpl False global_tvs local_tvs
+ givens wanteds `thenTc` \ (free_insts, binds, wanteds') ->
+ checkTc (isEmptyBag wanteds')
+ (reduceErr wanteds') `thenTc_`
returnTc (free_insts, binds)
\end{code}
@tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
-is not overloaded.
+is not overloaded.
\begin{code}
-tcSimplifyRank2 :: [TyVar] -- ``Local'' type variables; guaranteed fixpoint of subst
- -> [Inst] -- Given
- -> UnifyErrContext
- -> TcM ([Inst], -- Free
- [(Inst, TypecheckedExpr)]) -- Bindings
-
-tcSimplifyRank2 local_tvs givens err_ctxt
- = applyTcSubstToInsts givens `thenNF_Tc` \ givens' ->
- elimTyCons False
- (\tv -> not (tv `is_elem` local_tvs))
+tcSimplifyRank2 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint
+ -> LIE s -- Given
+ -> TcM s (LIE s, -- Free
+ [(TcIdOcc s,TcExpr s)]) -- Bindings
+
+
+tcSimplifyRank2 local_tvs givens
+ = zonkLIE givens `thenNF_Tc` \ givens' ->
+ elimTyCons True
+ (\tv -> not (tv `elementOfTyVarSet` local_tvs))
-- This predicate claims that all
-- any non-local tyvars are global,
-- thereby postponing dealing with
-- ambiguity until the enclosing Gen
- [] givens' `thenTc` \ (free, dict_binds, wanteds) ->
+ emptyLIE givens' `thenTc` \ (free, dict_binds, wanteds) ->
- checkTc (not (null wanteds)) (reduceErr wanteds err_ctxt) `thenTc_`
+ checkTc (isEmptyBag wanteds) (reduceErr wanteds) `thenTc_`
- returnTc (free, dict_binds)
- where
- is_elem = isIn "tcSimplifyRank2"
+ returnTc (free, bagToList dict_binds)
\end{code}
@tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
mechansim with the extra flag to say ``beat out constant insts''.
\begin{code}
-tcSimplifyTop :: [Inst] -> TcM [(Inst, TypecheckedExpr)]
+tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)]
tcSimplifyTop dicts
- = tcSimpl False [] [] [] dicts `thenTc` \ (_, binds, _) ->
+ = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs ->
+ tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) ->
returnTc binds
\end{code}
only interested in the simplified bunch of class/type constraints.
\begin{code}
-tcSimplifyThetas :: (Class -> TauType -> InstOrigin) -- Creates an origin for the dummy dicts
+tcSimplifyThetas :: (Class -> TauType -> InstOrigin s) -- Creates an origin for the dummy dicts
-> [(Class, TauType)] -- Simplify this
- -> TcM [(Class, TauType)] -- Result
+ -> TcM s [(Class, TauType)] -- Result
+tcSimplifyThetas = panic "tcSimplifyThetas"
+
+{- LATER
tcSimplifyThetas mk_inst_origin theta
= let
- dicts = map mk_dummy_dict theta
+ dicts = listToBag (map mk_dummy_dict theta)
in
-- Do the business (this is just the heart of "tcSimpl")
- elimTyCons False (\tv -> False) [] dicts `thenTc` \ (_, _, dicts2) ->
+ elimTyCons True (\tv -> False) emptyLIE dicts `thenTc` \ (_, _, dicts2) ->
-- Deal with superclass relationships
elimSCs [] dicts2 `thenNF_Tc` \ (_, dicts3) ->
- returnTc (map unmk_dummy_dict dicts3)
+ returnTc (map unmk_dummy_dict (bagToList dicts3))
where
- mk_dummy_dict (clas, ty)
- = Dict uniq clas ty (mk_inst_origin clas ty)
+ mk_dummy_dict (clas, ty) = Dict uniq clas ty (mk_inst_origin clas ty) mkUnknownSrcLoc
+ uniq = panic "tcSimplifyThetas:uniq"
- uniq = panic "tcSimplifyThetas:uniq"
-
- unmk_dummy_dict (Dict _ clas ty _) = (clas, ty)
+ unmk_dummy_dict (Dict _ clas ty _ _) = (clas, ty)
+-}
\end{code}
@tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
whether it worked or not.
\begin{code}
-tcSimplifyCheckThetas :: InstOrigin -- context; for error msg
- -> [(Class, TauType)] -- Simplify this
- -> TcM ()
+tcSimplifyCheckThetas :: InstOrigin s -- context; for error msg
+ -> [(Class, TauType)] -- Simplify this
+ -> TcM s ()
+
+tcSimplifyCheckThetas = panic "tcSimplifyCheckThetas"
+{- LATER
tcSimplifyCheckThetas origin theta
= let
dicts = map mk_dummy_dict theta
in
-- Do the business (this is just the heart of "tcSimpl")
- elimTyCons False (\tv -> False) [] dicts `thenTc` \ _ ->
+ elimTyCons True (\tv -> False) emptyLIE dicts `thenTc` \ _ ->
returnTc ()
where
mk_dummy_dict (clas, ty)
- = Dict uniq clas ty origin
+ = Dict uniq clas ty origin mkUnknownSrcLoc
uniq = panic "tcSimplifyCheckThetas:uniq"
+-}
\end{code}
%************************************************************************
\begin{code}
-elimTyCons :: Bool -- True <=> Don't simplify const insts
- -> (TyVar -> Bool) -- Free tyvar predicate
- -> [Inst] -- Given
- -> [Inst] -- Wanted
- -> TcM ([Inst], -- Free
- [(Inst, TypecheckedExpr)], -- Bindings
- [Inst] -- Remaining wanteds; no dups;
+elimTyCons :: Bool -- True <=> Simplify const insts
+ -> (TcTyVar s -> Bool) -- Free tyvar predicate
+ -> LIE s -- Given
+ -> LIE s -- Wanted
+ -> TcM s (LIE s, -- Free
+ Bag (TcIdOcc s, TcExpr s), -- Bindings
+ LIE s -- Remaining wanteds; no dups;
-- dicts only (no Methods)
)
\end{code}
let <yet-more-bindings> ...
\begin{code}
-elimTyCons dont_squash_consts is_free_tv givens wanteds
- = eTC givens wanteds
+elimTyCons squash_consts is_free_tv givens wanteds
+ = eTC givens (bagToList wanteds) `thenTc` \ (_, free, binds, irreds) ->
+ returnTc (free,binds,irreds)
where
- eTC :: [Inst] -> [Inst]
- -> TcM ([Inst], [(Inst, TypecheckedExpr)], [Inst])
-
- eTC _ [] = returnTc ([], [], [])
-
- eTC givens (wanted:wanteds) = try givens wanted wanteds
- (extractTyVarsFromInst wanted)
- (find_equiv givens wanted)
- -- find_equiv looks in "givens" for an inst equivalent to "wanted"
- -- This is used only in Case 2 below; it's like a guard which also
- -- returns a result.
+-- eTC :: LIE s -> [Inst s]
+-- -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s)
- try :: [Inst] -> Inst -> [Inst] -> [TyVar] -> (Maybe Inst)
- -> TcM ([Inst], [(Inst, TypecheckedExpr)], [Inst])
+ eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag)
- -- Case 0: same as existing dict, so build a simple binding
- try givens wanted wanteds tvs_of_wanted (Just this)
- = eTC givens wanteds `thenTc` \ (frees, binds, wanteds') ->
- let
+ eTC givens (wanted:wanteds)
+ -- Case 0: same as an existing inst
+ | maybeToBool maybe_equiv
+ = eTC givens wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
+ let
-- Create a new binding iff it's needed
- new_binds | instBindingRequired wanted = (wanted, Var (mkInstId this)):binds
- | otherwise = binds
- in
- returnTc (frees, new_binds, wanteds')
+ this = expectJust "eTC" maybe_equiv
+ new_binds | instBindingRequired wanted = (instToId wanted, HsVar (instToId this))
+ `consBag` binds
+ | otherwise = binds
+ in
+ returnTc (givens1, frees, new_binds, irreds)
-- Case 1: constrains no type variables at all
-- In this case we have a quick go to see if it has an
-- instance which requires no inputs (ie a constant); if so we use
-- it; if not, we give up on the instance and just heave it out the
-- top in the free result
- try givens wanted wanteds tvs_of_wanted _ | null tvs_of_wanted
- = simplify_it dont_squash_consts {- If dont_squash_consts is true,
- simplify only if trival -}
+ | isEmptyTyVarSet tvs_of_wanted
+ = simplify_it squash_consts {- If squash_consts is false,
+ simplify only if trival -}
givens wanted wanteds
-- Case 2: constrains free vars only, so fling it out the top in free_ids
- try givens wanted wanteds tvs_of_wanted _
- | all is_free_tv tvs_of_wanted
- = eTC (wanted:givens) wanteds `thenTc` \ (frees, binds, wanteds') ->
- returnTc (wanted:frees, binds, wanteds')
+ | all is_free_tv (tyVarSetToList tvs_of_wanted)
+ = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
+ returnTc (givens1, wanted `consBag` frees, binds, irreds)
-- Case 3: is a dict constraining only a tyvar,
-- so return it as part of the "wanteds" result
- try givens wanted wanteds tvs_of_wanted _
| isTyVarDict wanted
- = eTC (wanted:givens) wanteds `thenTc` \ (frees, binds, wanteds') ->
- returnTc (frees, binds, wanted:wanteds')
+ = eTC (wanted `consBag` givens) wanteds `thenTc` \ (givens1, frees, binds, irreds) ->
+ returnTc (givens1, frees, binds, wanted `consBag` irreds)
-- Case 4: is not a simple dict, so look up in instance environment
- try givens wanted wanteds tvs_of_wanted _
- = simplify_it False {- Simplify even if not trivial -}
+ | otherwise
+ = simplify_it True {- Simplify even if not trivial -}
givens wanted wanteds
-
- simplify_it only_if_trivial givens wanted wanteds
- = if not (instBindingRequired wanted) then
- -- No binding required for this chap, so squash right away
- lookupNoBindInst_Tc wanted `thenTc` \ simpler_wanteds ->
-
- eTC givens simpler_wanteds `thenTc` \ (frees1, binds1, wanteds1) ->
- let
- new_givens = [new_given | (new_given,rhs) <- binds1]
- -- Typically binds1 is empty
- in
- eTC givens wanteds `thenTc` \ (frees2, binds2, wanteds2) ->
-
- returnTc (frees1 ++ frees2,
- binds1 ++ binds2,
- wanteds1 ++ wanteds2)
-
- else -- An binding is required for this inst
- lookupInst_Tc wanted `thenTc` \ (rhs, simpler_wanteds) ->
-
- if (only_if_trivial && not_var rhs) then
+ where
+ tvs_of_wanted = tyVarsOfInst wanted
+
+ -- Look for something in "givens" that matches "wanted"
+ Just the_equiv = maybe_equiv
+ maybe_equiv = foldBag seqMaybe try Nothing givens
+ try given | wanted `matchesInst` given = Just given
+ | otherwise = Nothing
+
+
+ simplify_it simplify_always givens wanted wanteds
+ -- Recover immediately on no-such-instance errors
+ = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE))
+ (simplify_one simplify_always givens wanted)
+ `thenTc` \ (givens1, frees1, binds1, irreds1) ->
+ eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) ->
+ returnTc (givens2, frees1 `plusLIE` frees2,
+ binds1 `unionBags` binds2,
+ irreds1 `plusLIE` irreds2)
+
+
+ simplify_one simplify_always givens wanted
+ | not (instBindingRequired wanted)
+ = -- No binding required for this chap, so squash right away
+ lookupInst wanted `thenTc` \ (simpler_wanteds, _) ->
+ eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
+ returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)
+
+ | otherwise
+ = -- An binding is required for this inst
+ lookupInst wanted `thenTc` \ (simpler_wanteds, bind@(_,rhs)) ->
+
+ if (not_var rhs && not simplify_always) then
-- Ho ho! It isn't trivial to simplify "wanted",
- -- because the rhs isn't a simple variable. The flag
- -- dont_squash_consts tells us to give up now and
+ -- because the rhs isn't a simple variable. Unless the flag
+ -- simplify_always is set, just give up now and
-- just fling it out the top.
- eTC (wanted:givens) wanteds `thenTc` \ (frees, binds, wanteds') ->
- returnTc (wanted:frees, binds, wanteds')
+ returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE)
else
- -- Aha! Either it's easy, or dont_squash_consts is
- -- False, so we must do it right here.
-
- eTC givens simpler_wanteds `thenTc` \ (frees1, binds1, wanteds1) ->
- let
- new_givens = [new_given | (new_given,rhs) <- binds1]
- in
- eTC (new_givens ++ [wanted] ++ wanteds1 ++ givens) wanteds
- `thenTc` \ (frees2, binds2, wanteds2) ->
- returnTc (frees1 ++ frees2,
- binds1 ++ [(wanted, rhs)] ++ binds2,
- wanteds1 ++ wanteds2)
- where
- not_var :: TypecheckedExpr -> Bool
- not_var (Var _) = False
- not_var other = True
-
- find_equiv :: [Inst] -> Inst -> Maybe Inst
- -- Look through the argument list for an inst which is
- -- equivalent to the second arg.
-
- find_equiv [] wanted = Nothing
- find_equiv (given:givens) wanted
- | wanted `matchesInst` given = Just given
- | otherwise = find_equiv givens wanted
+ -- Aha! Either it's easy, or simplify_always is True
+ -- so we must do it right here.
+ eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) ->
+ returnTc (wanted `consLIE` givens1, frees1,
+ binds1 `snocBag` bind,
+ irreds1)
+
+ not_var :: TcExpr s -> Bool
+ not_var (HsVar _) = False
+ not_var other = True
\end{code}
%************************************************************************
\begin{code}
-elimSCs :: [Inst] -- Given; no dups
- -> [Inst] -- Wanted; no dups; all dictionaries, all
+elimSCs :: LIE s -- Given; no dups
+ -> LIE s -- Wanted; no dups; all dictionaries, all
-- constraining just a type variable
- -> NF_TcM ([(Inst,TypecheckedExpr)], -- Bindings
- [Inst]) -- Minimal wanted set
+ -> NF_TcM s (Bag (TcIdOcc s,TcExpr s), -- Bindings
+ LIE s) -- Minimal wanted set
elimSCs givens wanteds
= -- Sort the wanteds so that subclasses occur before superclasses
elimSCs_help
- [dict | dict@(Dict _ _ _ _) <- givens] -- Filter out non-dictionaries
+ (filterBag isDict givens) -- Filter out non-dictionaries
(sortSC wanteds)
-elimSCs_help :: [Inst] -- Given; no dups
- -> [Inst] -- Wanted; no dups;
- -> NF_TcM ([(Inst,TypecheckedExpr)],-- Bindings
- [Inst]) -- Minimal wanted set
+elimSCs_help :: LIE s -- Given; no dups
+ -> [Inst s] -- Wanted; no dups;
+ -> NF_TcM s (Bag (TcIdOcc s, TcExpr s), -- Bindings
+ LIE s) -- Minimal wanted set
-elimSCs_help given [] = returnNF_Tc ([], [])
+elimSCs_help given [] = returnNF_Tc (emptyBag, emptyLIE)
-elimSCs_help givens (wanted@(Dict _ wanted_class wanted_ty wanted_orig):wanteds)
- = case (trySC givens wanted_class wanted_ty) of
+elimSCs_help givens (wanted:wanteds)
+ = trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) ->
+ elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) ->
+ returnNF_Tc (binds1 `unionBags` binds2, irreds1 `plusLIE` irreds2)
- Nothing -> -- No superclass relnship found
- elimSCs_help (wanted:givens) wanteds `thenNF_Tc` \ (binds, wanteds') ->
- returnNF_Tc (binds, wanted:wanteds')
- Just (given, classes) -> -- Aha! There's a superclass relnship
+trySC :: LIE s -- Givens
+ -> Inst s -- Wanted
+ -> NF_TcM s (LIE s, -- New givens,
+ Bag (TcIdOcc s,TcExpr s), -- Bindings
+ LIE s) -- Irreducible wanted set
- -- Build intermediate dictionaries
- let
- theta = [ (clas, wanted_ty) | clas <- classes ]
- in
- newDicts wanted_orig theta `thenNF_Tc` \ intermediates ->
+trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
+ | not (maybeToBool maybe_best_subclass_chain)
+ = -- No superclass relationship
+ returnNF_Tc (givens, emptyBag, unitLIE wanted)
- -- Deal with the recursive call
- elimSCs_help (wanted : (intermediates ++ givens)) wanteds
- `thenNF_Tc` \ (binds, wanteds') ->
+ | otherwise
+ = -- There's a subclass relationship with a "given"
+ -- Build intermediate dictionaries
+ let
+ theta = [ (clas, wanted_ty) | clas <- reverse classes ]
+ -- The reverse is because the list comes back in the "wrong" order I think
+ in
+ newDictsAtLoc wanted_orig loc theta `thenNF_Tc` \ (intermediates, _) ->
-- Create bindings for the wanted dictionary and the intermediates.
-- Later binds may depend on earlier ones, so each new binding is pushed
-- on the front of the accumulating parameter list of bindings
- let
- new_binds = mk_binds wanted wanted_class (intermediates ++ [given]) []
- in
- returnNF_Tc (new_binds ++ binds, wanteds')
- where
- mk_binds :: Inst -- Define this
- -> Class -- ...whose class is this
- -> [Inst] -- In terms of this sub-class chain
- -> [(Inst, TypecheckedExpr)] -- Push the binding on front of these
- -> [(Inst, TypecheckedExpr)]
-
- mk_binds dict clas [] binds_so_far = binds_so_far
- mk_binds dict clas (dict_sub@(Dict _ dict_sub_class ty _):dicts_sub) binds_so_far
- = mk_binds dict_sub dict_sub_class dicts_sub (new_bind:binds_so_far)
- where
- new_bind = (dict, DictApp (TyApp (Var (getSuperDictSelId dict_sub_class clas))
- [ty])
- [mkInstId dict_sub])
-
-
-trySC :: [Inst] -- Givens
- -> Class -> UniType -- Wanted
- -> Maybe (Inst, [Class]) -- Nothing if no link; Just (given, classes)
- -- if wanted can be given in terms of given, with
- -- intermediate classes specified
-trySC givens wanted_class wanted_ty
- = case subclass_relns of
- [] -> Nothing
- ((given, classes, _): _) -> Just (given, classes)
+ let
+ mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
+ = ((dict_sub, dict_sub_class),
+ (instToId dict, DictApp (TyApp (HsVar (RealId (getSuperDictSelId dict_sub_class
+ clas)))
+ [ty])
+ [instToId dict_sub]))
+ (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
+ in
+ returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
+ listToBag new_binds,
+ emptyLIE)
+
where
- subclass_relns :: [(Inst, [Class], Int)] -- Subclass of wanted,
- -- intervening classes,
- -- and number of intervening classes
- -- Sorted with shortest link first
- subclass_relns = sortLt reln_lt (catMaybes (map find_subclass_reln givens))
+ maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
+ Just (given, classes, _) = maybe_best_subclass_chain
- reln_lt :: (Inst, [Class], Int) -> (Inst, [Class], Int) -> Bool
- (_,_,n1) `reln_lt` (_,_,n2) = n1 < n2
+ choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2 = c1
+ | otherwise = c2
+ choose_best Nothing c2 = c2
+ choose_best c1 Nothing = c1
- find_subclass_reln given@(Dict _ given_class given_ty _)
- | wanted_ty == given_ty
+ find_subclass_chain given@(Dict _ given_class given_ty _ _)
+ | wanted_ty `eqSimpleTy` given_ty
= case (wanted_class `isSuperClassOf` given_class) of
Just classes -> Just (given,
| otherwise = Nothing
-sortSC :: [Inst] -- Expected to be all dicts (no MethodIds), all of
+sortSC :: LIE s -- Expected to be all dicts (no MethodIds), all of
-- which constrain type variables
- -> [Inst] -- Sorted with subclasses before superclasses
+ -> [Inst s] -- Sorted with subclasses before superclasses
-sortSC dicts = sortLt lt dicts
+sortSC dicts = sortLt lt (bagToList dicts)
where
- (Dict _ c1 ty1 _) `lt` (Dict _ c2 ty2 _)
- = tv1 `ltTyVar` tv2 ||
- (tv1 `eqTyVar` tv2 && maybeToBool (c2 `isSuperClassOf` c1))
- where
- tv1 = getTyVar "sortSC" ty1
- tv2 = getTyVar "sortSC" ty2
+ (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
+ = if ty1 `eqSimpleTy` ty2 then
+ maybeToBool (c2 `isSuperClassOf` c1)
+ else
+ -- order is immaterial, I think...
+ False
\end{code}
We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
For each method @Inst@ in the @init_lie@ that mentions one of the
@Ids@, we create a binding. We return the remaining @Insts@ (in an
-@LIE@), as well as the @Binds@ generated.
+@LIE@), as well as the @HsBinds@ generated.
\begin{code}
-bindInstsOfLocalFuns :: LIE -> [Id] -> NF_TcM (LIE, TypecheckedMonoBinds)
+bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
bindInstsOfLocalFuns init_lie local_ids
- = let
- insts = unMkLIE init_lie
- in
- bind_insts insts [] EmptyMonoBinds
+ = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
where
- bind_insts :: [Inst] -- Insts to mangle
- -> [Inst] -- accum. Insts to return
- -> TypecheckedMonoBinds -- accum. Binds to return
- -> NF_TcM (LIE, TypecheckedMonoBinds)
-
- bind_insts [] acc_insts acc_binds
- = returnNF_Tc (mkLIE acc_insts, acc_binds)
-
- bind_insts (inst@(Method uniq id tys orig):insts) acc_insts acc_binds
+ bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds)
| id `is_elem` local_ids
- = noFailTc (lookupInst_Tc inst) `thenNF_Tc` \ (expr, dict_insts) ->
- let
- bind = VarMonoBind (mkInstId inst) expr
- in
- bind_insts insts (dict_insts ++ acc_insts) (bind `AndMonoBinds` acc_binds)
+ = lookupInst inst `thenTc` \ (dict_insts, (id,rhs)) ->
+ returnTc (listToBag dict_insts `plusLIE` insts,
+ VarMonoBind id rhs `AndMonoBinds` binds)
- bind_insts (some_other_inst:insts) acc_insts acc_binds
+ bind_inst some_other_inst (insts, binds)
-- Either not a method, or a method instance for an id not in local_ids
- = bind_insts insts (some_other_inst:acc_insts) acc_binds
+ = returnTc (some_other_inst `consBag` insts, binds)
is_elem = isIn "bindInstsOfLocalFuns"
\end{code}
+
+
+%************************************************************************
+%* *
+\section[Disambig]{Disambiguation of overloading}
+%* *
+%************************************************************************
+
+
+If a dictionary constrains a type variable which is
+\begin{itemize}
+\item
+not mentioned in the environment
+\item
+and not mentioned in the type of the expression
+\end{itemize}
+then it is ambiguous. No further information will arise to instantiate
+the type variable; nor will it be generalised and turned into an extra
+parameter to a function.
+
+It is an error for this to occur, except that Haskell provided for
+certain rules to be applied in the special case of numeric types.
+
+Specifically, if
+\begin{itemize}
+\item
+at least one of its classes is a numeric class, and
+\item
+all of its classes are numeric or standard
+\end{itemize}
+then the type variable can be defaulted to the first type in the
+default-type list which is an instance of all the offending classes.
+
+So here is the function which does the work. It takes the ambiguous
+dictionaries and either resolves them (producing bindings) or
+complains. It works by splitting the dictionary list by type
+variable, and using @disambigOne@ to do the real business.
+
+IMPORTANT: @disambiguate@ assumes that its argument dictionaries
+constrain only a simple type variable.
+
+\begin{code}
+type SimpleDictInfo s = (Inst s, Class, TcTyVar s)
+
+disambiguateDicts :: LIE s -> TcM s ()
+
+disambiguateDicts insts
+ = mapTc disambigOne inst_infos `thenTc` \ binds_lists ->
+ returnTc ()
+ where
+ inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts))
+ (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2
+
+ mk_inst_info dict@(Dict _ clas ty _ _)
+ = (dict, clas, getTyVar "disambiguateDicts" ty)
+\end{code}
+
+@disambigOne@ assumes that its arguments dictionaries constrain all
+the same type variable.
+
+ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
+@()@ instead of @Int@. I reckon this is the Right Thing to do since
+the most common use of defaulting is code like:
+\begin{verbatim}
+ _ccall_ foo `seqPrimIO` bar
+\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 ()
+
+disambigOne dict_infos
+ | not (isStandardNumericDefaultable classes)
+ = failTc (ambigErr dicts) -- no default
+
+ | otherwise -- isStandardNumericDefaultable dict_infos
+ = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
+ -- SO, TRY DEFAULT TYPES IN ORDER
+
+ -- Failure here is caused by there being no type in the
+ -- default list which can satisfy all the ambiguous classes.
+ -- For example, if Real a is reqd, but the only type in the
+ -- default list is Int.
+ tcGetDefaultTys `thenNF_Tc` \ default_tys ->
+ let
+ try_default [] -- No defaults work, so fail
+ = failTc (defaultErr dicts default_tys)
+
+ try_default (default_ty : default_tys)
+ = tryTc (try_default default_tys) $ -- If default_ty fails, we try
+ -- default_tys instead
+ tcSimplifyCheckThetas DefaultDeclOrigin thetas `thenTc` \ _ ->
+ returnTc default_ty
+ where
+ thetas = classes `zip` repeat default_ty
+ in
+ -- See if any default works, and if so bind the type variable to it
+ try_default default_tys `thenTc` \ chosen_default_ty ->
+ tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome!
+ unifyTauTy (mkTyVarTy tyvar) chosen_default_tc_ty
+
+ where
+ (_,_,tyvar) = head dict_infos -- Should be non-empty
+ dicts = [dict | (dict,_,_) <- dict_infos]
+ classes = [clas | (_,clas,_) <- dict_infos]
+
+\end{code}
+
+@isStandardNumericDefaultable@ sees whether the dicts have the
+property required for defaulting; namely at least one is numeric, and
+all are standard; or all are CcallIsh.
+
+\begin{code}
+isStandardNumericDefaultable :: [Class] -> Bool
+
+isStandardNumericDefaultable classes
+ | any isNumericClass classes && all isStandardClass classes
+ = True
+
+isStandardNumericDefaultable classes
+ | all isCcallishClass classes
+ = True
+
+isStandardNumericDefaultable classes
+ = False
+\end{code}
+
+
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+ToDo: for these error messages, should we note the location as coming
+from the insts, or just whatever seems to be around in the monad just
+now?
+
+\begin{code}
+genCantGenErr insts sty -- Can't generalise these Insts
+ = ppHang (ppStr "Cannot generalise these overloadings (in a _ccall_):")
+ 4 (ppAboves (map (ppr sty) (bagToList insts)))
+\end{code}
+
+\begin{code}
+ambigErr insts sty
+ = ppHang (ppStr "Ambiguous overloading")
+ 4 (ppAboves (map (ppr sty) insts))
+\end{code}
+
+@reduceErr@ complains if we can't express required dictionaries in
+terms of the signature.
+
+\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)))
+ )
+\end{code}
+
+\begin{code}
+defaultErr dicts defaulting_tys sty
+ = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
+ 4 (ppAboves [
+ ppHang (ppStr "Conflicting:")
+ 4 (ppInterleave ppSemi (map (ppr sty) dicts)),
+ ppHang (ppStr "Defaulting types :")
+ 4 (ppr sty defaulting_tys),
+ ppStr "([Int, Double] is the default list of defaulting types.)" ])
+\end{code}
+
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[TcTyClsDecls]{Typecheck type and class declarations}
+
+\begin{code}
+#include "HsVersions.h"
+
+module TcTyClsDecls (
+ tcTyAndClassDecls1
+ ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn ( TyDecl(..), ConDecl(..), BangType(..),
+ ClassDecl(..), MonoType(..), PolyType(..),
+ Sig(..), MonoBinds, Fake, InPat )
+import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..) )
+
+import TcMonad
+import Inst ( InstanceMapper(..) )
+import TcClassDcl ( tcClassDecl1 )
+import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
+ tcExtendGlobalValEnv, tcExtendKindEnv,
+ tcTyVarScope, tcGetEnv )
+import TcKind ( TcKind, newKindVars )
+import TcTyDecls ( tcTyDecl )
+
+import Bag
+import Class ( Class(..), getClassSelIds )
+import Digraph ( findSCCs, SCC(..) )
+import Name ( Name, isTyConName )
+import PprStyle
+import Pretty
+import UniqSet ( UniqSet(..), emptyUniqSet,
+ singletonUniqSet, unionUniqSets,
+ unionManyUniqSets, uniqSetToList )
+import SrcLoc ( SrcLoc )
+import TyCon ( TyCon, getTyConDataCons )
+import Unique ( Unique )
+import Util ( panic, pprTrace )
+
+\end{code}
+
+The main function
+~~~~~~~~~~~~~~~~~
+\begin{code}
+data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
+
+tcTyAndClassDecls1 :: InstanceMapper
+ -> Bag RenamedTyDecl -> Bag RenamedClassDecl
+ -> TcM s (TcEnv s)
+
+tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
+ = sortByDependency syn_decls cls_decls decls `thenTc` \ groups ->
+ tcGroups inst_mapper groups
+ where
+ cls_decls = mapBag ClD rncls_decls
+ ty_decls = mapBag TyD rnty_decls
+ syn_decls = filterBag is_syn_decl ty_decls
+ decls = ty_decls `unionBags` cls_decls
+
+ is_syn_decl (TyD (TySynonym _ _ _ _)) = True
+ is_syn_decl _ = False
+
+tcGroups inst_mapper []
+ = tcGetEnv `thenNF_Tc` \ env ->
+ returnTc env
+
+tcGroups inst_mapper (group:groups)
+ = tcGroup inst_mapper group `thenTc` \ new_env ->
+
+ -- Extend the environment using the new tycons and classes
+ tcSetEnv new_env $
+
+ -- Do the remaining groups
+ tcGroups inst_mapper groups
+\end{code}
+
+Dealing with a group
+~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s)
+tcGroup inst_mapper decls
+ = fixTc ( \ ~(tycons,classes,_) ->
+
+ pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
+
+ -- EXTEND TYPE AND CLASS ENVIRONMENTS
+ -- including their data constructors and class operations
+ tcExtendTyConEnv tycons $
+ tcExtendClassEnv classes $
+ tcExtendGlobalValEnv (concat (map getTyConDataCons tycons)) $
+ tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $
+
+ -- SNAFFLE ENV TO RETURN
+ tcGetEnv `thenNF_Tc` \ final_env ->
+
+ -- DEAL WITH TYPE VARIABLES
+ tcTyVarScope tyvar_names ( \ tyvars ->
+
+ -- MANUFACTURE NEW KINDS, AND EXTEND KIND ENV
+ newKindVars (length tycon_names) `thenNF_Tc` \ tycon_kinds ->
+ newKindVars (length class_names) `thenNF_Tc` \ class_kinds ->
+ tcExtendKindEnv tycon_names tycon_kinds $
+ tcExtendKindEnv class_names class_kinds $
+
+
+ -- DEAL WITH THE DEFINITIONS THEMSELVES
+ foldBag combine (tcDecl inst_mapper)
+ (returnTc (emptyBag, emptyBag))
+ decls
+ ) `thenTc` \ (tycons,classes) ->
+
+ returnTc (bagToList tycons, bagToList classes, final_env)
+ ) `thenTc` \ (_, _, final_env) ->
+ returnTc final_env
+
+ where
+ (tyvar_names, tycon_names, class_names) = get_binders decls
+
+ combine do_a do_b
+ = do_a `thenTc` \ (a1,a2) ->
+ do_b `thenTc` \ (b1,b2) ->
+ returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
+\end{code}
+
+Dealing with one decl
+~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcDecl :: InstanceMapper
+ -> Decl
+ -> TcM s (Bag TyCon, Bag Class)
+
+tcDecl inst_mapper (TyD decl)
+ = tcTyDecl decl `thenTc` \ tycon ->
+ returnTc (unitBag tycon, emptyBag)
+
+tcDecl inst_mapper (ClD decl)
+ = tcClassDecl1 inst_mapper decl `thenTc` \ clas ->
+ returnTc (emptyBag, unitBag clas)
+\end{code}
+
+Dependency analysis
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
+sortByDependency syn_decls cls_decls decls
+ = let -- CHECK FOR SYNONYM CYCLES
+ syn_sccs = findSCCs mk_edges syn_decls
+ syn_cycles = [map fmt_decl (bagToList decls)
+ | CyclicSCC decls <- syn_sccs]
+
+ in
+ checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
+
+ let -- CHECK FOR CLASS CYCLES
+ cls_sccs = findSCCs mk_edges cls_decls
+ cls_cycles = [map fmt_decl (bagToList decls)
+ | CyclicSCC decls <- cls_sccs]
+
+ in
+ checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
+
+ -- DO THE MAIN DEPENDENCY ANALYSIS
+ let
+ decl_sccs = findSCCs mk_edges decls
+ scc_bags = map bag_acyclic decl_sccs
+ in
+ returnTc (scc_bags)
+
+ where
+ bag_acyclic (AcyclicSCC scc) = unitBag scc
+ bag_acyclic (CyclicSCC sccs) = sccs
+
+fmt_decl (TyD (TySynonym name _ _ _)) = (ppr PprForUser name, getSrcLoc name)
+fmt_decl (ClD (ClassDecl _ name _ _ _ _ _)) = (ppr PprForUser name, getSrcLoc name)
+\end{code}
+
+Edges in Type/Class decls
+~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+mk_edges (TyD (TyData ctxt name _ condecls _ _ _))
+ = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
+mk_edges (TyD (TyNew ctxt name _ condecl _ _ _))
+ = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
+mk_edges (TyD (TySynonym name _ rhs _))
+ = (getItsUnique name, set_to_bag (get_ty rhs))
+mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
+ = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
+
+get_ctxt ctxt
+ = unionManyUniqSets (map (set_name.fst) ctxt)
+
+get_cons cons
+ = unionManyUniqSets (map get_con cons)
+ where
+ get_con (ConDecl _ btys _)
+ = unionManyUniqSets (map get_bty btys)
+ get_con (ConOpDecl bty1 _ bty2 _)
+ = unionUniqSets (get_bty bty1) (get_bty bty2)
+ get_con (NewConDecl _ ty _)
+ = get_ty ty
+ get_con (RecConDecl _ nbtys _)
+ = unionManyUniqSets (map (get_bty.snd) nbtys)
+
+ get_bty (Banged ty) = get_ty ty
+ get_bty (Unbanged ty) = get_ty ty
+
+get_ty (MonoTyVar tv)
+ = emptyUniqSet
+get_ty (MonoTyApp name tys)
+ = (if isTyConName name then set_name name else emptyUniqSet)
+ `unionUniqSets` get_tys tys
+get_ty (MonoFunTy ty1 ty2)
+ = unionUniqSets (get_ty ty1) (get_ty ty2)
+get_ty (MonoListTy ty)
+ = get_ty ty -- careful when defining [] (,,) etc as
+get_ty (MonoTupleTy tys) -- [ty] (ty,ty,ty) will not give edges!
+ = get_tys tys
+get_ty other = panic "TcTyClsDecls:get_ty"
+
+get_pty (HsForAllTy _ ctxt mty)
+ = get_ctxt ctxt `unionUniqSets` get_ty mty
+get_pty other = panic "TcTyClsDecls:get_pty"
+
+get_tys tys
+ = unionManyUniqSets (map get_ty tys)
+
+get_sigs sigs
+ = unionManyUniqSets (map get_sig sigs)
+ where
+ get_sig (ClassOpSig _ ty _ _) = get_pty ty
+ get_sig other = panic "TcTyClsDecls:get_sig"
+
+set_name name = singletonUniqSet (getItsUnique name)
+
+set_to_bag set = listToBag (uniqSetToList set)
+\end{code}
+
+Extract *binding* names from type and class decls. Type variables are
+bound in type, data, newtype and class declarations and the polytypes
+in the class op sigs.
+
+Why do we need to grab all these type variables at once, including
+those locally-quantified type variables in class op signatures?
+Because we can only commit to the final kind of a type variable when
+we've completed the mutually recursive group. For example:
+
+class C a where
+ op :: D b => a -> b -> b
+
+class D c where
+ bop :: (Monad c) => ...
+
+Here, the kind of the locally-polymorphic type variable "b"
+depends on *all the uses of class D*. For example, the use of
+Monad c in bop's type signature means that D must have kind Type->Type.
+
+
+\begin{code}
+get_binders :: Bag Decl
+ -> ([Name], -- TyVars; no dups
+ [Name], -- Tycons; no dups
+ [Name]) -- Classes; no dups
+
+get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
+ where
+ (tyvars, tycons, classes) = foldBag union3 get_binders1
+ (emptyBag,emptyBag,emptyBag)
+ decls
+
+ union3 (a1,a2,a3) (b1,b2,b3)
+ = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
+
+get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
+ = (listToBag tyvars, unitBag name, emptyBag)
+get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
+ = (listToBag tyvars, unitBag name, emptyBag)
+get_binders1 (TyD (TySynonym name tyvars _ _))
+ = (listToBag tyvars, unitBag name, emptyBag)
+get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
+ = (unitBag tyvar `unionBags` sigs_tvs sigs,
+ emptyBag, unitBag name)
+
+-- ToDo: will this duplicate the class tyvar
+
+sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
+ where
+ sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty
+ pty_tvs (HsForAllTy tvs _ _) = listToBag tvs
+\end{code}
+
+
+\begin{code}
+typeCycleErr syn_cycles sty
+ = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
+
+classCycleErr cls_cycles sty
+ = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
+
+pp_cycle sty str things
+ = ppHang (ppStr str)
+ 4 (ppAboves (map pp_thing things))
+ where
+ pp_thing (pp_name, loc)
+ = ppCat [pp_name, ppr sty loc]
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface TcTyDecls where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import FiniteMap(FiniteMap)
-import HsDecls(DataTypeSig, TyDecl)
-import Id(Id)
-import Maybes(Labda)
-import Name(Name)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcMonad(Baby_TcResult)
-import TyCon(TyCon)
-import UniType(UniType)
-import UniqFM(UniqFM)
-tcTyDecls :: E -> (Name -> Bool) -> (Name -> [DataTypeSig Name]) -> [TyDecl Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (UniqFM TyCon, [(Name, Id)], FiniteMap TyCon [(Bool, [Labda UniType])])
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The AQUA Project, Glasgow University, 1996
%
-\section[TcTyDecls]{Typecheck algebraic datatypes and type synonyms}
+\section[TcTyDecls]{Typecheck type declarations}
\begin{code}
#include "HsVersions.h"
-module TcTyDecls ( tcTyDecls ) where
-
-import TcMonad -- typechecking monad machinery
-import AbsSyn -- the stuff being typechecked
-
-import AbsUniType ( applyTyCon, mkDataTyCon, mkSynonymTyCon,
- getUniDataTyCon, isUnboxedDataType,
- isTyVarTemplateTy, cmpUniTypeMaybeList,
- pprMaybeTy
- )
-import CE ( lookupCE, CE(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import E ( getE_TCE, getE_CE, plusGVE, nullGVE, GVE(..), E )
-import ErrUtils ( addShortErrLocLine )
-import Errors ( confusedNameErr, specDataNoSpecErr, specDataUnboxedErr )
-import FiniteMap ( FiniteMap, emptyFM, plusFM, singletonFM )
-import IdInfo ( SpecEnv, mkSpecEnv, SpecInfo(..) )
+module TcTyDecls (
+ tcTyDecl,
+ tcConDecl
+ ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), MonoType )
+import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) )
+
+import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
+import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass )
+import TcMonad
+import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
+
+import Id ( mkDataCon, StrictnessMark(..) )
+import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
+import SpecEnv ( SpecEnv(..), nullSpecEnv )
+import Name ( getNameFullName, Name(..) )
import Pretty
-import SpecTyFuns ( specialiseConstrTys )
-import TCE -- ( nullTCE, unitTCE, lookupTCE, plusTCE, TCE(..), UniqFM )
-import TVE ( mkTVE, TVE(..) )
-import TcConDecls ( tcConDecls )
-import TcMonoType ( tcMonoType )
-import TcPragmas ( tcDataPragmas, tcTypePragmas )
-import Util
+import TyCon ( TyCon, ConsVisible(..), NewOrData(..), mkSynTyCon, mkDataTyCon )
+import Type ( getTypeKind )
+import TyVar ( getTyVarKind )
+import Util ( panic )
+
\end{code}
-We consult the @CE@/@TCE@ arguments {\em only} to build knots!
+\begin{code}
+tcTyDecl :: RenamedTyDecl -> TcM s TyCon
+\end{code}
-The resulting @TCE@ has info about the type constructors in it; the
-@GVE@ has info about their data constructors.
+Type synonym decls
+~~~~~~~~~~~~~~~~~~
\begin{code}
-tcTyDecls :: E
- -> (Name -> Bool) -- given Name, is it an abstract synonym?
- -> (Name -> [RenamedDataTypeSig]) -- given Name, get specialisation pragmas
- -> [RenamedTyDecl]
- -> Baby_TcM (TCE, GVE,
- FiniteMap TyCon [(Bool, [Maybe UniType])])
- -- specialisations:
- -- True => imported data types i.e. from interface file
- -- False => local data types i.e. requsted by source pragmas
-
-tcTyDecls e _ _ [] = returnB_Tc (nullTCE, nullGVE, emptyFM)
-
-tcTyDecls e is_abs_syn get_spec_sigs (tyd: tyds)
- = tc_decl tyd `thenB_Tc` \ (tce1, gve1, specs1) ->
- tcTyDecls e is_abs_syn get_spec_sigs tyds
- `thenB_Tc` \ (tce2, gve2, specs2) ->
+tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (tySynCtxt tycon_name) $
+
+ -- Look up the pieces
+ tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, rec_tycon) ->
+ mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
+
+ -- Look at the rhs
+ tcMonoTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
+
+ -- Unify tycon kind with (k1->...->kn->rhs)
+ unifyKind tycon_kind
+ (foldr mkTcArrowKind rhs_kind tyvar_kinds)
+ `thenTc_`
let
- tce3 = tce1 `plusTCE` tce2
- gve3 = gve1 `plusGVE` gve2
- specs3 = specs1 `plusFM` specs2
+ -- Construct the tycon
+ result_kind, final_tycon_kind :: Kind -- NB not TcKind!
+ result_kind = getTypeKind rhs_ty
+ final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
+
+ tycon = mkSynTyCon (getItsUnique tycon_name)
+ (getNameFullName tycon_name)
+ final_tycon_kind
+ (length tyvar_names)
+ rec_tyvars
+ rhs_ty
in
- returnB_Tc (tce3, gve3, specs3)
- where
- rec_ce = getE_CE e
- rec_tce = getE_TCE e
-
- -- continued...
+ returnTc tycon
\end{code}
-We don't need to substitute here, because the @TCE@s
-(which are at the top level) cannot contain free type variables.
+Algebraic data and newtype decls
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Gather relevant info:
\begin{code}
- tc_decl (TyData context name@(PreludeTyCon uniq full_name arity True{-"data"-})
- tyvars con_decls derivings pragmas src_loc)
- -- ToDo: context
- = tc_data_decl uniq name full_name arity tyvars con_decls
- derivings pragmas src_loc
-
- tc_decl (TyData context name@(OtherTyCon uniq full_name arity True{-"data"-} _)
- tyvars con_decls derivings pragmas src_loc)
- -- ToDo: context
- = tc_data_decl uniq name full_name arity tyvars con_decls
- derivings pragmas src_loc
-
- tc_decl (TyData _ bad_name _ _ _ _ src_loc)
- = failB_Tc (confusedNameErr "Bad name on a datatype constructor (a Prelude name?)"
- bad_name src_loc)
-
- tc_decl (TySynonym name@(PreludeTyCon uniq full_name arity False{-"type"-})
- tyvars mono_ty pragmas src_loc)
- = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc
-
- tc_decl (TySynonym name@(OtherTyCon uniq full_name arity False{-"type"-} _)
- tyvars mono_ty pragmas src_loc)
- = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc
-
- tc_decl (TySynonym bad_name _ _ _ src_loc)
- = failB_Tc (confusedNameErr "Bad name on a type-synonym constructor (a Prelude name?)"
- bad_name src_loc)
-\end{code}
+tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
+ = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
-Real work for @data@ declarations:
-\begin{code}
- tc_data_decl uniq name full_name arity tyvars con_decls derivings pragmas src_loc
- = addSrcLocB_Tc src_loc (
- let
- (tve, new_tyvars, _) = mkTVE tyvars
- rec_tycon = lookupTCE rec_tce name
- -- We know the lookup will succeed, because we are just
- -- about to put it in the outgoing TCE!
-
- spec_sigs = get_spec_sigs name
- in
- tcSpecDataSigs rec_tce spec_sigs [] `thenB_Tc` \ user_spec_infos ->
-
- recoverIgnoreErrorsB_Tc ([], []) (
- tcDataPragmas rec_tce tve rec_tycon new_tyvars pragmas
- ) `thenB_Tc` \ (pragma_con_decls, pragma_spec_infos) ->
- let
- (condecls_to_use, ignore_condecl_errors_if_pragma)
- = if null pragma_con_decls then
- (con_decls, id)
- else
- if null con_decls
- then (pragma_con_decls, recoverIgnoreErrorsB_Tc nullGVE)
- else panic "tcTyDecls:data: user and pragma condecls!"
-
- (imported_specs, specinfos_to_use)
- = if null pragma_spec_infos then
- (False, user_spec_infos)
- else
- if null user_spec_infos
- then (True, pragma_spec_infos)
- else panic "tcTyDecls:data: user and pragma specinfos!"
-
- specenv_to_use = mkSpecEnv specinfos_to_use
- in
- ignore_condecl_errors_if_pragma
- (tcConDecls rec_tce tve rec_tycon new_tyvars specenv_to_use condecls_to_use)
- `thenB_Tc` \ gve ->
- let
- condecls = map snd gve
-
- derived_classes = map (lookupCE rec_ce) derivings
-
- new_tycon
- = mkDataTyCon uniq
- full_name arity new_tyvars condecls
+tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
+ = tcTyDataOrNew NewType context tycon_name tyvar_names con_decl derivings pragmas src_loc
+
+
+tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (tyDataCtxt tycon_name) $
+
+ -- Lookup the pieces
+ tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, rec_tycon) ->
+ mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
+ tc_derivs derivings `thenNF_Tc` \ derived_classes ->
+
+ -- Typecheck the context
+ tcContext context `thenTc` \ ctxt ->
+
+ -- Unify tycon kind with (k1->...->kn->Type)
+ unifyKind tycon_kind
+ (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
+ `thenTc_`
+ -- Walk the condecls
+ mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
+ `thenTc` \ con_ids ->
+ let
+ -- Construct the tycon
+ final_tycon_kind :: Kind -- NB not TcKind!
+ final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
+
+ tycon = mkDataTyCon (getItsUnique tycon_name)
+ final_tycon_kind
+ (getNameFullName tycon_name)
+ rec_tyvars
+ ctxt
+ con_ids
derived_classes
- (null pragma_con_decls)
- -- if constrs are from pragma we are *abstract*
-
- spec_list
- = [(imported_specs, maybe_tys) | (SpecInfo maybe_tys _ _) <- specinfos_to_use]
-
- spec_map
- = if null spec_list then
- emptyFM
- else
- singletonFM rec_tycon spec_list
- in
- returnB_Tc (unitTCE uniq new_tycon, gve, spec_map)
- -- It's OK to return pragma condecls in gve, even
- -- though some of those names should be "invisible",
- -- because the *renamer* is supposed to have dealt with
- -- naming/scope issues already.
- )
+ ConsVisible -- For now; if constrs are from pragma we are *abstract*
+ data_or_new
+ in
+ returnTc tycon
+ where
+ tc_derivs Nothing = returnNF_Tc []
+ tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
+
+ tc_deriv name
+ = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
+ returnNF_Tc clas
\end{code}
-Real work for @type@ (synonym) declarations:
+
+Constructors
+~~~~~~~~~~~~
\begin{code}
- tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc
- = addSrcLocB_Tc src_loc (
-
- let (tve, new_tyvars, _) = mkTVE tyvars
- in
- tcMonoType rec_ce rec_tce tve mono_ty `thenB_Tc` \ expansion ->
- let
- -- abstractness info either comes from the interface pragmas
- -- (tcTypePragmas) or from a user-pragma in this module
- -- (is_abs_syn)
- abstract = tcTypePragmas pragmas
- || is_abs_syn name
-
- new_tycon = mkSynonymTyCon uniq full_name
- arity new_tyvars expansion (not abstract)
- in
- returnB_Tc (unitTCE uniq new_tycon, nullGVE, emptyFM)
- )
-\end{code}
+tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
-%************************************************************************
-%* *
-\subsection{Specialisation Signatures for Data Type declarations}
-%* *
-%************************************************************************
+tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
+ = tcAddSrcLoc src_loc $
+ let
+ (stricts, tys) = sep_bangs btys
+ in
+ mapTc tcMonoType tys `thenTc` \ arg_tys ->
+ let
+ data_con = mkDataCon (getItsUnique name)
+ (getNameFullName name)
+ stricts
+ tyvars
+ [] -- ToDo: ctxt; limited to tyvars in arg_tys
+ arg_tys
+ tycon
+ -- nullSpecEnv
+ in
+ returnTc data_con
-@tcSpecDataSigs@ checks data type specialisation signatures for
-validity, and returns the list of specialisation requests.
+tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
+ = tcAddSrcLoc src_loc $
+ let
+ (stricts, tys) = sep_bangs [bty1, bty2]
+ in
+ mapTc tcMonoType tys `thenTc` \ arg_tys ->
+ let
+ data_con = mkDataCon (getItsUnique op)
+ (getNameFullName op)
+ stricts
+ tyvars
+ [] -- ToDo: ctxt
+ arg_tys
+ tycon
+ -- nullSpecEnv
+ in
+ returnTc data_con
-\begin{code}
-tcSpecDataSigs :: TCE
- -> [RenamedDataTypeSig]
- -> [(RenamedDataTypeSig,SpecInfo)]
- -> Baby_TcM [SpecInfo]
-
-tcSpecDataSigs tce (s:ss) accum
- = tc_sig s `thenB_Tc` \ info ->
- tcSpecDataSigs tce ss ((s,info):accum)
- where
- tc_sig (SpecDataSig n ty src_loc)
- = addSrcLocB_Tc src_loc (
- let
- ty_names = extractMonoTyNames (==) ty
- (tve,_,_) = mkTVE ty_names
- fake_CE = panic "tcSpecDataSigs:CE"
- in
- -- Typecheck specialising type (includes arity check)
- tcMonoType fake_CE tce tve ty `thenB_Tc` \ tau_ty ->
- let
- (_,ty_args,_) = getUniDataTyCon tau_ty
- is_unboxed_or_tyvar ty = isUnboxedDataType ty || isTyVarTemplateTy ty
- in
- -- Check at least one unboxed type in specialisation
- checkB_Tc (not (any isUnboxedDataType ty_args))
- (specDataNoSpecErr n ty_args src_loc) `thenB_Tc_`
-
- -- Check all types are unboxed or tyvars
- -- (specific boxed types are redundant)
- checkB_Tc (not (all is_unboxed_or_tyvar ty_args))
- (specDataUnboxedErr n ty_args src_loc) `thenB_Tc_`
-
- let
- maybe_tys = specialiseConstrTys ty_args
- in
- returnB_Tc (SpecInfo maybe_tys 0 (panic "SpecData:SpecInfo:SpecId"))
- )
-
-tcSpecDataSigs tce [] accum
- = -- Remove any duplicates from accumulated specinfos
- getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr ->
-
- (if sw_chkr SpecialiseTrace && not (null duplicates) then
- pprTrace "Duplicate SPECIALIZE data pragmas:\n"
- (ppAboves (map specmsg sep_dups))
- else id)(
-
- (if sw_chkr SpecialiseTrace && not (null spec_infos) then
- pprTrace "Specialising "
- (ppHang (ppCat [ppr PprDebug name, ppStr "at types:"])
- 4 (ppAboves (map pp_spec spec_infos)))
-
- else id) (
-
- returnB_Tc (spec_infos)
- ))
- where
- spec_infos = map (snd . head) equiv
+tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
+ = tcAddSrcLoc src_loc $
+ tcMonoType ty `thenTc` \ arg_ty ->
+ let
+ data_con = mkDataCon (getItsUnique name)
+ (getNameFullName name)
+ [NotMarkedStrict]
+ tyvars
+ [] -- ToDo: ctxt
+ [arg_ty]
+ tycon
+ -- nullSpecEnv
+ in
+ returnTc data_con
- equiv = equivClasses cmp_info accum
- duplicates = filter (not . singleton) equiv
+tcConDecl tycon tyvars ctxt (RecConDecl con fields src_loc)
+ = panic "tcConDecls:RecConDecl"
- cmp_info (_, SpecInfo tys1 _ _) (_, SpecInfo tys2 _ _)
- = cmpUniTypeMaybeList tys1 tys2
- singleton [_] = True
- singleton _ = False
+sep_bangs btys
+ = unzip (map sep_bang btys)
+ where
+ sep_bang (Banged ty) = (MarkedStrict, ty)
+ sep_bang (Unbanged ty) = (NotMarkedStrict, ty)
+\end{code}
+
+
+
+Errors and contexts
+~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tySynCtxt tycon_name sty
+ = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
- sep_dups = tail (concat (map ((:) Nothing . map Just) duplicates))
- specmsg (Just (SpecDataSig _ ty locn, _))
- = addShortErrLocLine locn ( \ sty -> ppr sty ty ) PprDebug
- specmsg Nothing
- = ppStr "***"
+tyDataCtxt tycon_name sty
+ = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
- ((SpecDataSig name _ _, _):_) = accum
- pp_spec (SpecInfo tys _ _) = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- tys]
+tyNewCtxt tycon_name sty
+ = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
\end{code}
--- /dev/null
+\begin{code}
+module TcType (
+
+ TcTyVar(..),
+ newTcTyVar,
+ newTyVarTy, -- Kind -> NF_TcM s (TcType s)
+ newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType s]
+
+
+ TcTyVarSet(..),
+
+ -----------------------------------------
+ TcType(..), TcMaybe(..),
+ TcTauType(..), TcThetaType(..), TcRhoType(..),
+
+ -- Find the type to which a type variable is bound
+ tcWriteTyVar, -- :: TcTyVar s -> TcType s -> NF_TcM (TcType s)
+ tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s)
+
+
+ tcInstTyVar, -- TyVar -> NF_TcM s (TcTyVar s)
+ tcInstType, tcInstTcType, tcInstTheta,
+
+-- zonkTcType, -- TcType s -> NF_TcM s (TcType s)
+-- zonkTcTheta, -- TcThetaType s -> NF_TcM s (TcThetaType s)
+
+ zonkTcTyVars, -- TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
+ zonkTcType, -- TcType s -> NF_TcM s (TcType s)
+ zonkTcTypeToType, -- TcType s -> NF_TcM s Type
+ zonkTcTyVarToTyVar -- TcTyVar s -> NF_TcM s TyVar
+
+ ) where
+
+
+
+-- friends:
+import Type ( Type(..), ThetaType(..), GenType(..), tyVarsOfTypes, getTyVar_maybe )
+import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..),
+ tyVarSetToList
+ )
+
+-- others:
+import Kind ( Kind )
+import Usage ( Usage(..), GenUsage, UVar(..), duffUsage )
+import Class ( GenClass )
+import TcKind ( TcKind )
+import TcMonad
+
+import Ubiq
+import Unique ( Unique )
+import UniqFM ( UniqFM )
+import Name ( getNameShortName )
+import Maybes ( assocMaybe )
+import Util ( panic )
+\end{code}
+
+
+
+Data types
+~~~~~~~~~~
+
+\begin{code}
+type TcType s = GenType (TcTyVar s) UVar -- Used during typechecker
+ -- Invariant on ForAllTy in TcTypes:
+ -- forall a. T
+ -- a cannot occur inside a MutTyVar in T; that is,
+ -- T is "flattened" before quantifying over a
+
+type TcThetaType s = [(Class, TcType s)]
+type TcRhoType s = TcType s -- No ForAllTys
+type TcTauType s = TcType s -- No DictTys or ForAllTys
+
+type Box s = MutableVar s (TcMaybe s)
+
+data TcMaybe s = UnBound
+ | BoundTo (TcType s)
+
+-- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
+-- because you get a synonym loop if you do!
+
+type TcTyVar s = GenTyVar (Box s)
+type TcTyVarSet s = GenTyVarSet (Box s)
+\end{code}
+
+\begin{code}
+tcTyVarToTyVar :: TcTyVar s -> TyVar
+tcTyVarToTyVar (TyVar uniq kind name _) = TyVar uniq kind name duffUsage
+\end{code}
+
+Type instantiation
+~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+newTcTyVar :: Maybe ShortName -> Kind -> NF_TcM s (TcTyVar s)
+newTcTyVar name kind
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ tcNewMutVar UnBound `thenNF_Tc` \ box ->
+ returnNF_Tc (TyVar uniq kind name box)
+
+newTyVarTy :: Kind -> NF_TcM s (TcType s)
+newTyVarTy kind
+ = newTcTyVar Nothing kind `thenNF_Tc` \ tc_tyvar ->
+ returnNF_Tc (TyVarTy tc_tyvar)
+
+newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s]
+newTyVarTys n kind = mapNF_Tc newTyVarTy (take n (repeat kind))
+
+tcInstTyVar :: TyVar -> NF_TcM s (TcTyVar s)
+tcInstTyVar tyvar@(TyVar uniq kind name _)
+ = newTcTyVar name kind
+\end{code}
+
+@tcInstType@ and @tcInstTcType@ 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.
+
+\begin{code}
+tcInstType :: [(TyVar,TcType s)] -> Type -> NF_TcM s (TcType s)
+tcInstType tenv ty_to_inst
+ = do [(uniq,ty) | (TyVar uniq _ _ _, ty) <- tenv] ty_to_inst
+ where
+ do env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage)
+
+ do env (SynTy tycon tys ty) = mapNF_Tc (do env) tys `thenNF_Tc` \ tys' ->
+ do env ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (SynTy tycon tys' ty')
+
+ do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' ->
+ do env res `thenNF_Tc` \ res' ->
+ returnNF_Tc (FunTy arg' res' usage)
+
+ do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' ->
+ do env arg `thenNF_Tc` \ arg' ->
+ returnNF_Tc (AppTy fun' arg')
+
+ do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (DictTy clas ty' usage)
+
+ do env (TyVarTy (TyVar uniq kind name _))
+ = case assocMaybe env uniq of
+ Just tc_ty -> returnNF_Tc tc_ty
+ Nothing -> panic "tcInstType"
+
+ do env (ForAllTy (TyVar uniq kind name _) ty)
+ = newTcTyVar name kind `thenNF_Tc` \ tc_tyvar ->
+ let
+ new_env = (uniq, TyVarTy tc_tyvar) : env
+ in
+ do new_env ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (ForAllTy tc_tyvar ty')
+
+ -- ForAllUsage impossible
+
+
+tcInstTheta :: [(TyVar,TcType s)] -> ThetaType -> NF_TcM s (TcThetaType s)
+tcInstTheta tenv theta
+ = mapNF_Tc go theta
+ where
+ go (clas,ty) = tcInstType tenv ty `thenNF_Tc` \ tc_ty ->
+ returnNF_Tc (clas, tc_ty)
+
+tcInstTcType :: [(TcTyVar s,TcType s)] -> TcType s -> NF_TcM s (TcType s)
+tcInstTcType tenv ty_to_inst
+ = do [(uniq,ty) | (TyVar uniq _ _ _, ty) <- tenv] ty_to_inst
+ where
+ do env ty@(TyConTy tycon usage) = returnNF_Tc ty
+
+-- Could do clever stuff here to avoid instantiating constant types
+ do env (SynTy tycon tys ty) = mapNF_Tc (do env) tys `thenNF_Tc` \ tys' ->
+ do env ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (SynTy tycon tys' ty')
+
+ do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' ->
+ do env res `thenNF_Tc` \ res' ->
+ returnNF_Tc (FunTy arg' res' usage)
+
+ do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' ->
+ do env arg `thenNF_Tc` \ arg' ->
+ returnNF_Tc (AppTy fun' arg')
+
+ do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (DictTy clas ty' usage)
+
+ do env ty@(TyVarTy (TyVar uniq kind name _))
+ = case assocMaybe env uniq of
+ Just tc_ty -> returnNF_Tc tc_ty
+ Nothing -> returnNF_Tc ty
+
+ do env (ForAllTy (TyVar uniq kind name _) ty)
+ = newTcTyVar name kind `thenNF_Tc` \ tc_tyvar ->
+ let
+ new_env = (uniq, TyVarTy tc_tyvar) : env
+ in
+ do new_env ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (ForAllTy tc_tyvar ty')
+
+ -- ForAllUsage impossible
+\end{code}
+
+Reading and writing TcTyVars
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcWriteTyVar :: TcTyVar s -> TcType s -> NF_TcM s ()
+tcReadTyVar :: TcTyVar s -> NF_TcM s (TcMaybe s)
+\end{code}
+
+Writing is easy:
+
+\begin{code}
+tcWriteTyVar (TyVar uniq kind name box) ty = tcWriteMutVar box (BoundTo ty)
+\end{code}
+
+Reading is more interesting. The easy thing to do is just to read, thus:
+\begin{verbatim}
+tcReadTyVar (TyVar uniq kind name box) = tcReadMutVar box
+\end{verbatim}
+
+But it's more fun to short out indirections on the way: If this
+version returns a TyVar, then that TyVar is unbound. If it returns
+any other type, then there might be bound TyVars embedded inside it.
+
+We return Nothing iff the original box was unbound.
+
+\begin{code}
+tcReadTyVar (TyVar uniq kind name box)
+ = tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ UnBound -> returnNF_Tc UnBound
+ BoundTo ty -> short_out ty `thenNF_Tc` \ ty' ->
+ tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
+ returnNF_Tc (BoundTo ty')
+
+short_out :: TcType s -> NF_TcM s (TcType s)
+short_out ty@(TyVarTy (TyVar uniq kind name box))
+ = tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ UnBound -> returnNF_Tc ty
+ BoundTo ty' -> short_out ty' `thenNF_Tc` \ ty' ->
+ tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
+ returnNF_Tc ty'
+
+short_out other_ty = returnNF_Tc other_ty
+\end{code}
+
+
+Zonking
+~~~~~~~
+@zonkTcTypeToType@ converts from @TcType@ to @Type@. It follows through all
+the substitutions of course.
+
+\begin{code}
+zonkTcTypeToType :: TcType s -> NF_TcM s Type
+zonkTcTypeToType ty = zonk tcTyVarToTyVar ty
+
+zonkTcType :: TcType s -> NF_TcM s (TcType s)
+zonkTcType ty = zonk (\tyvar -> tyvar) ty
+
+zonkTcTyVars :: TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
+zonkTcTyVars tyvars
+ = mapNF_Tc (zonk_tv (\tyvar -> tyvar))
+ (tyVarSetToList tyvars) `thenNF_Tc` \ tys ->
+ returnNF_Tc (tyVarsOfTypes tys)
+
+zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
+zonkTcTyVarToTyVar tyvar
+ = zonk_tv_to_tv tcTyVarToTyVar tyvar
+
+
+zonk tyvar_fn (TyVarTy tyvar)
+ = zonk_tv tyvar_fn tyvar
+
+zonk tyvar_fn (AppTy ty1 ty2)
+ = zonk tyvar_fn ty1 `thenNF_Tc` \ ty1' ->
+ zonk tyvar_fn ty2 `thenNF_Tc` \ ty2' ->
+ returnNF_Tc (AppTy ty1' ty2')
+
+zonk tyvar_fn (TyConTy tc u)
+ = returnNF_Tc (TyConTy tc u)
+
+zonk tyvar_fn (SynTy tc tys ty)
+ = mapNF_Tc (zonk tyvar_fn) tys `thenNF_Tc` \ tys' ->
+ zonk tyvar_fn ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (SynTy tc tys' ty')
+
+zonk tyvar_fn (ForAllTy tv ty)
+ = zonk_tv_to_tv tyvar_fn tv `thenNF_Tc` \ tv' ->
+ zonk tyvar_fn ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (ForAllTy tv' ty')
+
+zonk tyvar_fn (ForAllUsageTy uv uvs ty)
+ = panic "zonk:ForAllUsageTy"
+
+zonk tyvar_fn (FunTy ty1 ty2 u)
+ = zonk tyvar_fn ty1 `thenNF_Tc` \ ty1' ->
+ zonk tyvar_fn ty2 `thenNF_Tc` \ ty2' ->
+ returnNF_Tc (FunTy ty1' ty2' u)
+
+zonk tyvar_fn (DictTy c ty u)
+ = zonk tyvar_fn ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (DictTy c ty' u)
+
+
+zonk_tv tyvar_fn tyvar
+ = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ UnBound -> returnNF_Tc (TyVarTy (tyvar_fn tyvar))
+ BoundTo ty -> zonk tyvar_fn ty
+
+
+zonk_tv_to_tv tyvar_fn tyvar
+ = zonk_tv tyvar_fn tyvar `thenNF_Tc` \ ty ->
+ case getTyVar_maybe ty of
+ Nothing -> panic "zonk_tv_to_tv"
+ Just tyvar -> returnNF_Tc tyvar
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Typecheck where
-import AbsSyn(Module)
-import Bag(Bag)
-import CE(CE(..))
-import Class(Class)
-import CmdLineOpts(GlobalSwitch)
-import E(E)
-import ErrUtils(Error(..))
-import FiniteMap(FiniteMap)
-import HsBinds(Bind, Binds, Sig)
-import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsImpExp(IE, ImportedInterface)
-import HsLit(Literal)
-import HsMatches(Match)
-import HsPat(InPat, RenamedPat(..), TypecheckedPat)
-import HsTypes(PolyType)
-import Id(Id)
-import Inst(Inst)
-import Maybes(Labda, MaybeErr)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import PreludePS(_PackedString)
-import Pretty(PprStyle, Pretty(..), PrettyRep)
-import ProtoName(ProtoName)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import TcInstDcls(InstInfo)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Module a b
-data Bag a
-type CE = UniqFM Class
-data GlobalSwitch
-data E
-type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Binds a b
-data FixityDecl a
-data Expr a b
-data InPat a
-type RenamedPat = InPat Name
-data TypecheckedPat
-data Id
-data Inst
-data Labda a
-data MaybeErr a b
-data Name
-data PprStyle
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data ProtoName
-data SplitUniqSupply
-data InstInfo
-data UniqFM a
-typecheckModule :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Module Name (InPat Name) -> MaybeErr ((Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]), ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo), FiniteMap TyCon [(Bool, [Labda UniType])], E, PprStyle -> Int -> Bool -> PrettyRep) (Bag (PprStyle -> Int -> Bool -> PrettyRep))
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Typecheck]{Outside-world interfaces to the typechecker}
#include "HsVersions.h"
module Typecheck (
- typecheckModule,
-
- -- and to make the interface self-sufficient...
- Module, Bag, CE(..), Binds, FixityDecl, E, Expr, InPat,
- RenamedPat(..), TypecheckedPat, Id, Inst, Maybe, MaybeErr,
- Name, PprStyle, PrettyRep, ProtoName, Error(..), Pretty(..),
- InstInfo, SplitUniqSupply, GlobalSwitch, UniqFM
+ typecheckModule, InstInfo
) where
-import TcMonad -- typechecking monad machinery
-import AbsSyn -- the stuff being typechecked
+import Ubiq
+import TcMonad
+import TcModule ( tcModule )
+import TcInstUtil ( InstInfo )
+
+import HsSyn
+import RnHsSyn
+import TcHsSyn
-import E ( nullE, E )
+import ErrUtils ( TcWarning(..), TcError(..) )
+import Pretty
+import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
import Maybes ( MaybeErr(..) )
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import TcModule -- tcModule, and associated stuff
-import Util -- for pragmas only
\end{code}
The typechecker stuff lives inside a complicated world of @TcM@
-monadery. This module provides three interfaces into that world, one
-for typechecking a module, another for typechecking an expression, and
-one for typechecking an interface. This last one works as if
-@typecheckModule@ was applied to the very simple module:
-\begin{verbatim}
-module EmptyModule where
-
-import InterfaceOfInterest
-\end{verbatim}
-This is used when we want to augment an @E@ with information from an
-interface. (Used in the interpreter.)
+monadery.
+
+ToDo: Interfaces for interpreter ...
+ Typecheck an expression
+ Typecheck an interface
\begin{code}
-typecheckModule ::
- (GlobalSwitch -> Bool) -- cmd-line switch checker
- -> SplitUniqSupply -- name supply in
- -> GlobalNameFuns -- renamer info (for doing derivings)
- -> RenamedModule -- input module
-
- -> ------- OUTPUTS -----------
- -- depends v much on whether typechecking succeeds or not!
+typecheckModule
+ :: UniqSupply -- name supply in
+ -> GlobalNameMappers -- renamer info (for doing derivings)
+ -> RenamedHsModule -- input module
+
+ -> -- OUTPUTS ...
MaybeErr
-- SUCCESS ...
- (((TypecheckedBinds, -- binds from class decls; does NOT
- -- include default-methods bindings
- TypecheckedBinds, -- binds from instance decls; INCLUDES
- -- class default-methods binds
- TypecheckedBinds, -- binds from value decls
- [(Inst, TypecheckedExpr)]),
-
- ([RenamedFixityDecl], -- things for the interface generator
- [Id], -- to look at...
- CE,
- TCE,
- Bag InstInfo),
-
- FiniteMap TyCon [(Bool, [Maybe UniType])],
+ (((TypecheckedHsBinds, -- binds from class decls; does NOT
+ -- include default-methods bindings
+ TypecheckedHsBinds, -- binds from instance decls; INCLUDES
+ -- class default-methods binds
+ TypecheckedHsBinds, -- binds from value decls
+
+ [(Id, TypecheckedHsExpr)] -- constant instance binds
+ ),
+
+ ([RenamedFixityDecl], [Id], UniqFM TyCon, UniqFM Class, Bag InstInfo),
+ -- things for the interface generator
+
+ (UniqFM TyCon, UniqFM Class),
+ -- environments of info from this module only
+
+ FiniteMap TyCon [(Bool, [Maybe Type])],
-- source tycon specialisation requests
---UNUSED: E, -- new cumulative E (with everything)
- E, -- E just for stuff from THIS module
- -- NB: if you want the diff between two prev Es: i.e.,
- -- things in cumulative E that were added because of
- -- this module's import-ery, just do:
- -- bigE `minusE` thisModuleE
+ PprStyle->Pretty), -- stuff to print for -ddump-deriving
- PprStyle->Pretty)) -- stuff to print for -ddump-deriving
+ Bag TcWarning) -- pretty-print this to get warnings
-- FAILURE ...
- (Bag Error) -- pretty-print this to find out what went wrong
+ (Bag TcError, -- pretty-print this to get errors
+ Bag TcWarning) -- pretty-print this to get warnings
-typecheckModule sw_chkr us renamer_name_funs modyule
- = initTc sw_chkr us (tcModule nullE renamer_name_funs modyule)
+typecheckModule us renamer_name_funs mod
+ = initTc us (tcModule renamer_name_funs mod)
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Unify where
-import Bag(Bag)
-import CmdLineOpts(GlobalSwitch)
-import ErrsTc(UnifyErrContext)
-import Pretty(PprStyle, PrettyRep)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc)
-import Subst(Subst)
-import TcMonad(TcResult)
-import UniType(UniType)
-unifyTauTy :: UniType -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-unifyTauTyList :: [UniType] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-unifyTauTyLists :: [UniType] -> [UniType] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Unify]{Unifier}
module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) where
-IMPORT_Trace -- ToDo: rm (debugging only)
-import Outputable
-import Pretty
+import Ubiq
-import AbsSyn
+-- friends:
import TcMonad
-
-import CmdLineOpts ( GlobalSwitch(..) )
-import CoreLift ( isUnboxedButNotState )
-import Errors ( unifyErr, UnifyErrInfo(..), UnifyErrContext )
-import Id ( Id, DataCon(..), Inst )
-import Maybes ( Maybe(..) )
-import Subst ( extendSubst, SubstResult(..), Subst )
-#if USE_ATTACK_PRAGMAS
-import Class ( Class(..), cmpClass ) -- .. for pragmas only
-import TyCon ( TyCon(..), isBoxedTyCon, isVisibleSynTyCon, cmpTyCon )
- -- .. on TyCon is for pragmas only
-import TyVar -- make all visible for pragmas
-import UniTyFuns ( pprUniType, pprTyCon )
-#else
-import Class ( Class )
-import TyVar ( TyVar(..), TyVarTemplate )
-import TyCon ( TyCon, isBoxedTyCon, isVisibleSynTyCon )
-#endif
-import UniType ( UniType(..), TauType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
+import Type ( GenType(..), getTypeKind )
+import TyCon ( TyCon(..), ConsVisible, NewOrData )
+import TyVar ( GenTyVar(..), TyVar(..) )
+import TcType ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..),
+ tcReadTyVar, tcWriteTyVar
+ )
+-- others:
+import Kind ( Kind, isSubKindOf )
+import PprType ( GenTyVar, GenType ) -- instances
+import Pretty
+import Unique ( Unique ) -- instances
import Util
\end{code}
-%************************************************************************
-%* *
-\subsection[Unify-spec]{Specification}
-%* *
-%************************************************************************
-
-CLAIM: the unifier works correctly even if the types to be unified are not
-fixed points of the substitution.
%************************************************************************
%* *
Unify two @TauType@s. Dead straightforward.
\begin{code}
-unifyTauTy :: TauType -> TauType -> UnifyErrContext -> TcM ()
-
-unifyTauTy ty1 ty2 err_ctxt = uTys ty1 ty1 ty2 ty2 err_ctxt
+unifyTauTy :: TcTauType s -> TcTauType s -> TcM s ()
+unifyTauTy ty1 ty2
+ = tcAddErrCtxt (unifyCtxt ty1 ty2) $
+ uTys ty1 ty1 ty2 ty2
\end{code}
-@unifyTauTyLists@ unifies corresponding elements of its two list
-arguments. The lists should be of equal length.
+@unifyTauTyList@ unifies corresponding elements of two lists of
+@TauType@s. It uses @uTys@ to do the real work. The lists should be
+of equal length. We charge down the list explicitly so that we can
+complain if their lengths differ.
\begin{code}
-unifyTauTyLists :: [TauType] -> [TauType] -> UnifyErrContext -> TcM ()
-
-unifyTauTyLists tys1 tys2 err_ctxt = uList tys1 tys2 err_ctxt
+unifyTauTyLists :: [TcTauType s] -> [TcTauType s] -> TcM s ()
+unifyTauTyLists [] [] = returnTc ()
+unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_`
+ unifyTauTyLists tys1 tys2
+unifyTauTypeLists ty1s ty2s = panic "Unify.unifyTauTypeLists: mismatched type lists!"
\end{code}
@unifyTauTyList@ takes a single list of @TauType@s and unifies them
lists, when all the elts should be of the same type.
\begin{code}
-unifyTauTyList :: [TauType] -> UnifyErrContext -> TcM ()
-
-unifyTauTyList [] _ = returnTc ()
-unifyTauTyList [ty] _ = returnTc ()
-
-unifyTauTyList (ty1:tys@(ty2:_)) err_ctxt
- = unifyTauTy ty1 ty2 err_ctxt `thenTc_`
- unifyTauTyList tys err_ctxt
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Unify-lists-of-types]{@uList@}
-%* *
-%************************************************************************
-
-@uList@ unifies corresponding elements of two lists of @TauType@s. It
-uses @uTys@ to do the real work. We charge down the list explicitly
-so that we can complain if their lengths differ.
-
-\begin{code}
-uList :: [TauType] -> [TauType]
- -> UnifyErrContext
- -> TcM ()
-
-uList [] [] _ = returnTc ()
-
-uList (ty1:tys1) (ty2:tys2) err_ctxt
- = uTys ty1 ty1 ty2 ty2 err_ctxt `thenTc_`
- uList tys1 tys2 err_ctxt
-
-uList ty1s ty2s _ = panic "Unify.uList: mismatched type lists!"
+unifyTauTyList :: [TcTauType s] -> TcM s ()
+unifyTauTyList [] = returnTc ()
+unifyTauTyList [ty] = returnTc ()
+unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_`
+ unifyTauTyList tys
\end{code}
%************************************************************************
We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''.
\begin{code}
-uTys :: TauType -> TauType -- Error reporting ty1 and real ty1
- -> TauType -> TauType -- Error reporting ty2 and real ty2
- -> UnifyErrContext
- -> TcM ()
+uTys :: TcTauType s -> TcTauType s -- Error reporting ty1 and real ty1
+ -> TcTauType s -> TcTauType s -- Error reporting ty2 and real ty2
+ -> TcM s ()
+
+ -- Variables; go for uVar
+uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar tyvar1 ps_ty2 ty2
+uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar tyvar2 ps_ty1 ty1
+
+ -- Applications and functions; just check the two parts
+uTys _ (FunTy fun1 arg1 _) _ (FunTy fun2 arg2 _)
+ = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2
+uTys _ (AppTy fun1 arg1) _ (AppTy fun2 arg2)
+ = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2
+
+ -- Type constructors must match
+uTys ps_ty1 (TyConTy con1 _) ps_ty2 (TyConTy con2 _)
+ = checkTc (con1 == con2) (unifyMisMatch ps_ty1 ps_ty2)
+
+ -- Always expand synonyms (see notes at end)
+uTys ps_ty1 (SynTy con1 args1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
+uTys ps_ty1 ty1 ps_ty2 (SynTy con2 args2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
+
+ -- Special case: converts (->) a b to a -> b
+uTys ps_ty1 (AppTy (AppTy (TyConTy FunTyCon u) fun) arg) ps_ty2 ty2
+ = uTys ps_ty1 (FunTy fun arg u) ps_ty2 ty2
+uTys ps_ty1 ty1 ps_ty2 (AppTy (AppTy (TyConTy FunTyCon u) fun) arg)
+ = uTys ps_ty1 ty1 ps_ty2 (FunTy fun arg u)
+
+ -- Anything else fails
+uTys ps_ty1 ty1 ps_ty2 ty2 = failTc (unifyMisMatch ps_ty1 ps_ty2)
\end{code}
-%********************************************************
-%* *
-Sanity check: should never find a UniTyVarTemplate
-%* *
-%********************************************************
-
-\begin{code}
-#ifdef DEBUG
-
-uTys ps_ty1 ty1@(UniTyVarTemplate tv1) ps_ty2 ty2 err_ctxt
- = pprPanic "Unify:uTys:unifying w/ UniTyVarTemplate(1):" (ppCat [ppr PprDebug tv1, ppr PprDebug ty2])
-
-uTys ps_ty1 ty1 ps_ty2 ty2@(UniTyVarTemplate tv2) err_ctxt
- = pprPanic "Unify:uTys:unifying w/ UniTyVarTemplate(2):" (ppCat [ppr PprDebug ty1, ppr PprDebug tv2])
-
-#endif {-DEBUG-}
-\end{code}
-
-%********************************************************
-%* *
-Both variables:
-%* *
-%********************************************************
-
-\begin{code}
-uTys ps_ty1 (UniTyVar tyvar1) ps_ty2 ty2 err_ctxt = uVar tyvar1 ps_ty2 ty2 err_ctxt
-uTys ps_ty1 ty1 ps_ty2 (UniTyVar tyvar2) err_ctxt = uVar tyvar2 ps_ty1 ty1 err_ctxt
-\end{code}
-
-%********************************************************
-%* *
-Both function constructors:
-%* *
-%********************************************************
+%************************************************************************
+%* *
+\subsection[Unify-uVar]{@uVar@: unifying with a type variable}
+%* *
+%************************************************************************
-\begin{code}
-uTys _ (UniFun fun1 arg1) _ (UniFun fun2 arg2) err_ctxt
- = uList [fun1, arg1] [fun2, arg2] err_ctxt
-\end{code}
+@uVar@ is called when at least one of the types being unified is a
+variable. It does {\em not} assume that the variable is a fixed point
+of the substitution; rather, notice that @bindTo@ (defined below) nips
+back into @uTys@ if it turns out that the variable is already bound.
-%********************************************************
-%* *
-Both datatype constructors:
-%* *
-%********************************************************
+There is a slight worry that one might try to @bindTo@ a (say) Poly
+tyvar (as tv1) with an Open tyvar (as ty2) which is already unified to
+an unboxed type. In fact this can't happen, because the Open ones are
+always the ones which are unified away.
\begin{code}
-uTys ps_ty1 ty1@(UniData con1 args1) ps_ty2 ty2@(UniData con2 args2) err_ctxt
- = if (con1 == con2) then
- -- Same constructors, just unify the arguments
- uList args1 args2 err_ctxt
- else
- -- Different constructors: disaster
- getSrcLocTc `thenNF_Tc` \ src_loc ->
- failTc (unifyErr (UnifyMisMatch ps_ty1 ps_ty2) err_ctxt src_loc)
-\end{code}
-
-%********************************************************
-%* *
-Type synonyms:
-%* *
-%********************************************************
+uVar :: TcTyVar s
+ -> TcTauType s -> TcTauType s -- printing and real versions
+ -> TcM s ()
-If just one or the other is a synonym, just expand it.
+uVar tv1 ps_ty2 ty2
+ = tcReadTyVar tv1 `thenNF_Tc` \ maybe_ty1 ->
+ case maybe_ty1 of
+ BoundTo ty1 -> uTys ty1 ty1 ps_ty2 ty2
+ UnBound -> uUnboundVar tv1 ps_ty2 ty2
-\begin{code}
-uTys ps_ty1 (UniSyn con1 args1 ty1) ps_ty2 ty2 err_ctxt
- | isVisibleSynTyCon con1
- = uTys ps_ty1 ty1 ps_ty2 ty2 err_ctxt
-
-uTys ps_ty1 ty1 ps_ty2 (UniSyn con2 args2 ty2) err_ctxt
- | isVisibleSynTyCon con2
- = uTys ps_ty1 ty1 ps_ty2 ty2 err_ctxt
+ -- Expand synonyms
+uUnboundVar tv1 ps_ty2 (SynTy _ _ ty2) = uUnboundVar tv1 ps_ty2 ty2
+
+
+ -- The both-type-variable case
+uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1)
+ ps_ty2
+ ty2@(TyVarTy tv2@(TyVar uniq2 kind2 name2 box2))
+
+ -- Same type variable => no-op
+ | uniq1 == uniq2
+ = returnTc ()
+
+ -- Distinct type variables
+ | otherwise
+ = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
+ case maybe_ty2 of
+ BoundTo ty2' -> uUnboundVar tv1 ty2' ty2'
+ UnBound -> if kind2 `isSubKindOf` kind1 then
+ tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc ()
+ else if kind1 `isSubKindOf` kind2 then
+ tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
+ else
+ failTc (unifyKindErr tv1 ps_ty2)
+
+ -- Second one isn't a type variable
+uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) ps_ty2 non_var_ty2
+ = occur_check non_var_ty2 `thenTc_`
+ checkTc (getTypeKind non_var_ty2 `isSubKindOf` kind1)
+ (unifyKindErr tv1 ps_ty2) `thenTc_`
+ tcWriteTyVar tv1 non_var_ty2 `thenNF_Tc_`
+ returnTc ()
+ where
+ occur_check (TyVarTy tv2@(TyVar uniq2 _ _ box2))
+ | uniq1 == uniq2 -- Same tyvar; fail
+ = failTc (unifyOccurCheck tv1 ps_ty2)
+
+ | otherwise -- A different tyvar
+ = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
+ case maybe_ty2 of
+ BoundTo ty2' -> occur_check ty2'
+ UnBound -> returnTc ()
+
+ occur_check (AppTy fun arg) = occur_check fun `thenTc_` occur_check arg
+ occur_check (FunTy fun arg _) = occur_check fun `thenTc_` occur_check arg
+ occur_check (TyConTy _ _) = returnTc ()
+ occur_check (SynTy _ _ ty2) = occur_check ty2
+ occur_check other = panic "Unexpected Dict or ForAll in occurCheck"
\end{code}
+Notes on synonyms
+~~~~~~~~~~~~~~~~~
If you are tempted to make a short cut on synonyms, as in this
pseudocode...
\begin{verbatim}
-uTys (UniSyn con1 args1 ty1) (UniSyn con2 args2 ty2)
+uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
= if (con1 == con2) then
-- Good news! Same synonym constructors, so we can shortcut
-- by unifying their arguments and ignoring their expansions.
- uList args1 args2
+ unifyTauTypeLists args1 args2
else
-- Never mind. Just expand them and try again
uTys ty1 ty2
user.
\end{quotation}
-Still, if the synonym is abstract, we can only just go ahead and try!
-
-\begin{code}
-uTys ps_ty1 (UniSyn con1 args1 ty1) ps_ty2 (UniSyn con2 args2 ty2) err_ctxt
- -- Both must be abstract (i.e., non "visible" -- not done yet)
- = if (con1 == con2) then
- -- Good news! Same synonym constructors, so we can shortcut
- -- by unifying their arguments and ignoring their expansions.
- uList args1 args2 err_ctxt
- else
- -- Bad news; mis-matched type constructors
- getSrcLocTc `thenNF_Tc` \ src_loc ->
- failTc (unifyErr (UnifyMisMatch ps_ty1 ps_ty2) err_ctxt src_loc)
-\end{code}
-%********************************************************
-%* *
-Catch-all case---just fails:
-%* *
-%********************************************************
+Errors
+~~~~~~
-Anything else fails. For example, matching a @UniFun@ against
-a @UniData@.
\begin{code}
-uTys ps_ty1 ty1 ps_ty2 ty2 err_ctxt
- = getSrcLocTc `thenNF_Tc` \ src_loc ->
- failTc (unifyErr (UnifyMisMatch ps_ty1 ps_ty2) err_ctxt src_loc)
+unifyCtxt ty1 ty2 sty
+ = ppAboves [
+ ppCat [ppStr "Expected:", ppr sty ty1],
+ ppCat [ppStr " Actual:", ppr sty ty2]
+ ]
+
+unifyMisMatch ty1 ty2 sty
+ = ppHang (ppStr "Couldn't match the type")
+ 4 (ppSep [ppr sty ty1, ppStr "against", ppr sty ty2])
+
+unifyKindErr tyvar ty sty
+ = ppHang (ppStr "Kind mis-match between")
+ 4 (ppSep [ppr sty tyvar, ppStr "and", ppr sty ty])
+
+unifyOccurCheck tyvar ty sty
+ = ppHang (ppStr "Occur check: cannot construct the infinite type")
+ 4 (ppSep [ppr sty tyvar, ppStr "=", ppr sty ty])
\end{code}
-%************************************************************************
-%* *
-\subsection[Unify-uVar]{@uVar@: unifying with a type variable}
-%* *
-%************************************************************************
-
-@uVar@ is called when at least one of the types being unified is a
-variable. It does {\em not} assume that the variable is a fixed point
-of the substitution; rather, notice that @bindTo@ (defined below) nips
-back into @uTys@ if it turns out that the variable is already bound.
-
-There is a slight worry that one might try to @bindTo@ a (say) Poly
-tyvar (as tv1) with an Open tyvar (as ty2) which is already unified to
-an unboxed type. In fact this can't happen, because the Open ones are
-always the ones which are unified away.
-
-\begin{code}
-uVar :: TyVar
- -> UniType -> UniType -- printing and real versions
- -> UnifyErrContext
- -> TcM ()
-
-uVar tv1 ps_ty2 ty2 err_ctxt
- = do tv1 ty2
- where
- -- Expand synonyms
- do _ (UniSyn _ _ ty2) = do tv1 ty2
-
- -- Commit any open type variable
- do (OpenSysTyVar _) ty2 = tv1 `bindTo` ps_ty2
- do _ ty2@(UniTyVar tv2@(OpenSysTyVar _)) = tv2 `bindTo` ty1
-
- -- Eliminate Poly in favour of User
- do (PolySysTyVar _) ty2@(UniTyVar (UserTyVar _ _)) = tv1 `bindTo` ps_ty2
- do (PolySysTyVar _) ty2@(UniTyVar (PolySysTyVar _)) = tv1 `bindTo` ps_ty2
- do (UserTyVar _ _) ty2@(UniTyVar tv2@(PolySysTyVar _)) = tv2 `bindTo` ty1
- do (UserTyVar _ _) ty2@(UniTyVar (UserTyVar _ _)) = tv1 `bindTo` ps_ty2
-
- -- Matching for boxed data types
- do (PolySysTyVar _) ty2@(UniData con _) | isBoxedTyCon con = tv1 `bindTo` ps_ty2
- do (UserTyVar _ _) ty2@(UniData con _) | isBoxedTyCon con = tv1 `bindTo` ps_ty2
-
- -- Matching for unboxed data types:
- -- requires specialisation w.r.t. the unboxed type
- do (PolySysTyVar _) ty2@(UniData con _) = tv1 `bindToUnboxed` ps_ty2
- do (UserTyVar _ _) ty2@(UniData con _) = tv1 `bindToUnboxed` ps_ty2
-
- -- Matching for function types
- do (PolySysTyVar _) ty2@(UniFun _ _) = tv1 `bindTo` ps_ty2
- do (UserTyVar _ _) ty2@(UniFun _ _) = tv1 `bindTo` ps_ty2
-
- -- Default
- do _ _ = getSrcLocTc `thenNF_Tc` \ src_loc ->
- failTc (unifyErr (UnifyMisMatch ty1 ps_ty2) err_ctxt src_loc)
-
- ----------- END OF CASES ---------------
-
- ty1 = UniTyVar tv1
-
- tyvar1 `bindTo` ty2
- = extendSubstTc tyvar1 ty2 err_ctxt
-
- tyvar1 `bindToUnboxed` ty2
- = getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
- if sw_chkr SpecialiseUnboxed && isUnboxedButNotState ty2 then
- extendSubstTc tyvar1 ty2 err_ctxt
- else
- getSrcLocTc `thenNF_Tc` \ src_loc ->
- failTc (unifyErr (UnifyUnboxedMisMatch ty1 ps_ty2) err_ctxt src_loc)
-\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[Class]{The @Class@ datatype}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Class (
+ GenClass(..), Class(..),
+
+ mkClass,
+ getClassKey, getClassOps, getClassSelIds,
+ getSuperDictSelId, getClassOpId, getDefaultMethodId,
+ getClassSig, getClassBigSig, getClassInstEnv,
+ isSuperClassOf,
+
+ derivableClassKeys, cCallishClassKeys,
+ isNumericClass, isStandardClass, isCcallishClass,
+
+ GenClassOp(..), ClassOp(..),
+ mkClassOp,
+ getClassOpTag, getClassOpString,
+ getClassOpLocalType,
+
+ ClassInstEnv(..)
+
+ -- and to make the interface self-sufficient...
+ ) where
+
+CHK_Ubiq() -- debugging consistency check
+
+import TyLoop
+
+import TyCon ( TyCon )
+import TyVar ( TyVar(..), GenTyVar )
+import Usage ( GenUsage, Usage(..), UVar(..) )
+
+import Maybes ( assocMaybe, Maybe )
+import NameTypes ( FullName, ShortName )
+import Unique -- Keys for built-in classes
+import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+import Pretty ( Pretty(..), PrettyRep )
+import PprStyle ( PprStyle )
+import SrcLoc ( SrcLoc )
+import Util
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Class-basic]{@Class@: basic definition}
+%* *
+%************************************************************************
+
+A @Class@ corresponds to a Greek kappa in the static semantics:
+
+The parameterisation wrt tyvar and uvar is only necessary to
+get appropriately general instances of Ord3 for GenType.
+
+\begin{code}
+data GenClassOp ty
+ = ClassOp FAST_STRING -- The operation name
+
+ Int -- Unique within a class; starts at 1
+
+ ty -- Type; the class tyvar is free (you can find
+ -- it from the class). This means that a
+ -- ClassOp doesn't make much sense outside the
+ -- context of its parent class.
+
+data GenClass tyvar uvar
+ = Class
+ Unique -- Key for fast comparison
+ FullName
+
+ tyvar -- The class type variable
+
+ [GenClass tyvar uvar] -- Immediate superclasses, and the
+ [Id] -- corresponding selector functions to
+ -- extract them from a dictionary of this
+ -- class
+
+ [GenClassOp (GenType tyvar uvar)] -- The * class operations
+ [Id] -- * selector functions
+ [Id] -- * default methods
+ -- They are all ordered by tag. The
+ -- selector ids are less innocent than they
+ -- look, because their IdInfos contains
+ -- suitable specialisation information. In
+ -- particular, constant methods are
+ -- instances of selectors at suitably simple
+ -- types.
+
+ ClassInstEnv -- Gives details of all the instances of this class
+
+ [(GenClass tyvar uvar, [GenClass tyvar uvar])]
+ -- Indirect superclasses;
+ -- (k,[k1,...,kn]) means that
+ -- k is an immediate superclass of k1
+ -- k1 is an immediate superclass of k2
+ -- ... and kn is an immediate superclass
+ -- of this class. (This is all redundant
+ -- information, since it can be derived from
+ -- the superclass information above.)
+
+type Class = GenClass TyVar UVar
+type ClassOp = GenClassOp Type
+
+type ClassInstEnv = MatchEnv Type Id -- The Ids are dfuns
+\end{code}
+
+The @mkClass@ function fills in the indirect superclasses.
+
+\begin{code}
+mkClass :: Unique -> FullName -> TyVar
+ -> [Class] -> [Id]
+ -> [ClassOp] -> [Id] -> [Id]
+ -> ClassInstEnv
+ -> Class
+
+mkClass uniq full_name tyvar super_classes superdict_sels
+ class_ops dict_sels defms class_insts
+ = Class uniq full_name tyvar
+ super_classes superdict_sels
+ class_ops dict_sels defms
+ class_insts
+ trans_clos
+ where
+ trans_clos :: [(Class,[Class])]
+ trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
+
+ succ (clas@(Class _ _ _ super_classes _ _ _ _ _ _), links)
+ = [(super, (clas:links)) | super <- super_classes]
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Class-selectors]{@Class@: simple selectors}
+%* *
+%************************************************************************
+
+The rest of these functions are just simple selectors.
+
+\begin{code}
+getClassKey (Class key _ _ _ _ _ _ _ _ _) = key
+getClassOps (Class _ _ _ _ _ ops _ _ _ _) = ops
+getClassSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
+
+getClassOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
+ = op_ids !! (getClassOpTag op - 1)
+getDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
+ = defm_ids !! (getClassOpTag op - 1)
+getSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
+ = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas
+
+getClassSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
+getClassSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
+ = (tyvar, super_classes, ops)
+
+getClassBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
+ = (tyvar, super_classes, sdsels, ops, sels, defms)
+
+getClassInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
+\end{code}
+
+@a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
+@b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the
+$k_1,\ldots,k_n$ are exactly as described in the definition of the
+@GenClass@ constructor above.
+
+\begin{code}
+isSuperClassOf :: Class -> Class -> Maybe [Class]
+clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Class-std-groups]{Standard groups of Prelude classes}
+%* *
+%************************************************************************
+
+@derivableClassKeys@ is also used in checking \tr{deriving} constructs
+(@TcDeriv@).
+
+NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
+even though every numeric class has these two as a superclass,
+because the list of ambiguous dictionaries hasn't been simplified.
+
+\begin{code}
+isNumericClass, isStandardClass :: Class -> Bool
+
+isNumericClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys
+isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
+isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
+is_elem = isIn "is_X_Class"
+
+numericClassKeys
+ = [ numClassKey,
+ realClassKey,
+ integralClassKey,
+ fractionalClassKey,
+ floatingClassKey,
+ realFracClassKey,
+ realFloatClassKey ]
+
+derivableClassKeys
+ = [ eqClassKey,
+ showClassKey,
+ ordClassKey,
+ enumClassKey,
+ ixClassKey,
+ readClassKey ]
+
+cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
+
+standardClassKeys
+ = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
+ --
+ -- We have to have "_CCallable" and "_CReturnable" in the standard
+ -- classes, so that if you go...
+ --
+ -- _ccall_ foo ... 93{-numeric literal-} ...
+ --
+ -- ... it can do The Right Thing on the 93.
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Class-instances]{Instance declarations for @Class@}
+%* *
+%************************************************************************
+
+We compare @Classes@ by their keys (which include @Uniques@).
+
+\begin{code}
+instance Ord3 (GenClass tyvar uvar) where
+ cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _)
+ = cmp k1 k2
+
+instance Eq (GenClass tyvar uvar) where
+ (Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2
+ (Class k1 _ _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
+
+instance Ord (GenClass tyvar uvar) where
+ (Class k1 _ _ _ _ _ _ _ _ _) <= (Class k2 _ _ _ _ _ _ _ _ _) = k1 <= k2
+ (Class k1 _ _ _ _ _ _ _ _ _) < (Class k2 _ _ _ _ _ _ _ _ _) = k1 < k2
+ (Class k1 _ _ _ _ _ _ _ _ _) >= (Class k2 _ _ _ _ _ _ _ _ _) = k1 >= k2
+ (Class k1 _ _ _ _ _ _ _ _ _) > (Class k2 _ _ _ _ _ _ _ _ _) = k1 > k2
+ _tagCmp a b = case cmp a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+\end{code}
+
+\begin{code}
+instance NamedThing (GenClass tyvar uvar) where
+ getExportFlag (Class _ n _ _ _ _ _ _ _ _) = getExportFlag n
+ isLocallyDefined (Class _ n _ _ _ _ _ _ _ _) = isLocallyDefined n
+ getOrigName (Class _ n _ _ _ _ _ _ _ _) = getOrigName n
+ getOccurrenceName (Class _ n _ _ _ _ _ _ _ _) = getOccurrenceName n
+ getInformingModules (Class _ n _ _ _ _ _ _ _ _) = getInformingModules n
+ getSrcLoc (Class _ n _ _ _ _ _ _ _ _) = getSrcLoc n
+ fromPreludeCore (Class _ n _ _ _ _ _ _ _ _) = fromPreludeCore n
+
+ getItsUnique (Class key _ _ _ _ _ _ _ _ _) = key
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
+%* *
+%************************************************************************
+
+A @ClassOp@ represents a a class operation. From it and its parent
+class we can construct the dictionary-selector @Id@ for the
+operation/superclass dictionary, and the @Id@ for its default method.
+It appears in a list inside the @Class@ object.
+
+The type of a method in a @ClassOp@ object is its local type; that is,
+without the overloading of the class itself. For example, in the
+declaration
+\begin{pseudocode}
+ class Foo a where
+ op :: Ord b => a -> b -> a
+\end{pseudocode}
+the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
+just
+ $\forall \beta.~
+ @Ord@~\beta \Rightarrow
+ \alpha \rightarrow \beta \rightarrow alpha$
+
+(where $\alpha$ is the class type variable recorded in the @Class@
+object). Of course, the type of @op@ recorded in the GVE will be its
+``full'' type
+
+ $\forall \alpha \forall \beta.~
+ @Foo@~\alpha \Rightarrow
+ ~@Ord@~\beta \Rightarrow \alpha
+ \rightarrow \beta \rightarrow alpha$
+
+******************************************************************
+**** That is, the type variables of a class op selector
+*** are all at the outer level.
+******************************************************************
+
+\begin{code}
+mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
+mkClassOp name tag ty = ClassOp name tag ty
+
+getClassOpTag :: GenClassOp ty -> Int
+getClassOpTag (ClassOp _ tag _) = tag
+
+getClassOpString :: GenClassOp ty -> FAST_STRING
+getClassOpString (ClassOp str _ _) = str
+
+getClassOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
+getClassOpLocalType (ClassOp _ _ ty) = ty
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
+%* *
+%************************************************************************
+
+@ClassOps@ are compared by their tags.
+
+\begin{code}
+instance Eq (GenClassOp ty) where
+ (ClassOp _ i1 _) == (ClassOp _ i2 _) = i1 == i2
+ (ClassOp _ i1 _) /= (ClassOp _ i2 _) = i1 == i2
+
+instance Ord (GenClassOp ty) where
+ (ClassOp _ i1 _) <= (ClassOp _ i2 _) = i1 <= i2
+ (ClassOp _ i1 _) < (ClassOp _ i2 _) = i1 < i2
+ (ClassOp _ i1 _) >= (ClassOp _ i2 _) = i1 >= i2
+ (ClassOp _ i1 _) > (ClassOp _ i2 _) = i1 > i2
+ -- ToDo: something for _tagCmp? (WDP 94/10)
+\end{code}
+
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[Kind]{The @Kind@ datatype}
+
+\begin{code}
+module Kind (
+ Kind(..), -- Only visible to friends: TcKind
+
+ mkArrowKind,
+ mkTypeKind,
+ mkUnboxedTypeKind,
+ mkBoxedTypeKind,
+
+ isSubKindOf,
+ resultKind, argKind
+ ) where
+
+import Ubiq{-uitous-}
+
+import Util ( panic )
+\end{code}
+
+\begin{code}
+data Kind
+ = TypeKind -- Any type (incl unboxed types)
+ | BoxedTypeKind -- Any boxed type
+ | UnboxedTypeKind -- Any unboxed type
+ | ArrowKind Kind Kind
+ deriving Eq
+
+mkArrowKind = ArrowKind
+mkTypeKind = TypeKind
+mkUnboxedTypeKind = UnboxedTypeKind
+mkBoxedTypeKind = BoxedTypeKind
+
+isSubKindOf :: Kind -> Kind -> Bool
+
+BoxedTypeKind `isSubKindOf` TypeKind = True
+UnboxedTypeKind `isSubKindOf` TypeKind = True
+kind1 `isSubKindOf` kind2 = kind1 == kind2
+
+resultKind :: Kind -> Kind -- Get result from arrow kind
+resultKind (ArrowKind _ res_kind) = res_kind
+resultKind other_kind = panic "resultKind"
+
+argKind :: Kind -> Kind -- Get argument from arrow kind
+argKind (ArrowKind arg_kind _) = arg_kind
+argKind other_kind = panic "argKind"
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[PprType]{Printing Types, TyVars, Classes, ClassOps, TyCons}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PprType(
+ GenTyVar, pprTyVar,
+ TyCon, pprTyCon,
+ GenType, pprType, pprParendType,
+ pprType_Internal,
+ getTypeString,
+ typeMaybeString,
+ specMaybeTysSuffix,
+ GenClass,
+ GenClassOp, pprClassOp
+ ) where
+
+import Ubiq
+import IdLoop -- for paranoia checking
+import TyLoop -- for paranoia checking
+import NameLoop -- for paranoia checking
+
+-- friends:
+-- (PprType can see all the representations it's trying to print)
+import Type ( GenType(..), maybeAppTyCon,
+ splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy )
+import TyVar ( GenTyVar(..) )
+import TyCon ( TyCon(..), ConsVisible, NewOrData )
+import Class ( Class(..), GenClass(..),
+ ClassOp(..), GenClassOp(..) )
+import Kind ( Kind(..) )
+
+-- others:
+import CStrings ( identToC )
+import CmdLineOpts ( opt_OmitInterfacePragmas )
+import Maybes ( maybeToBool )
+import NameTypes ( ShortName, FullName )
+import Outputable ( ifPprShowAll, isAvarop, interpp'SP )
+import PprStyle ( PprStyle(..), codeStyle )
+import Pretty
+import TysWiredIn ( listTyCon )
+import Unique ( pprUnique10, pprUnique )
+import Usage ( UVar(..), pprUVar )
+import Util
+\end{code}
+
+\begin{code}
+instance (Eq tyvar, Outputable tyvar,
+ Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where
+ ppr sty ty = pprType sty ty
+
+instance Outputable TyCon where
+ ppr sty tycon = pprTyCon sty tycon
+
+instance Outputable (GenClass tyvar uvar) where
+ -- we use pprIfaceClass for printing in interfaces
+ ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n
+
+instance Outputable ty => Outputable (GenClassOp ty) where
+ ppr sty clsop = pprClassOp sty clsop
+
+instance Outputable (GenTyVar flexi) where
+ ppr sty tv = pprTyVar sty tv
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Type]{@Type@}
+%* *
+%************************************************************************
+
+@pprType@ is the std @Type@ printer; the overloaded @ppr@ function is
+defined to use this. @pprParendType@ is the same, except it puts
+parens around the type, except for the atomic cases. @pprParendType@
+works just by setting the initial context precedence very high.
+
+\begin{code}
+pprType, pprParendType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => PprStyle -> GenType tyvar uvar -> Pretty
+
+pprType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC ty
+pprParendType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC ty
+
+pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
+pprMaybeTy sty Nothing = ppChar '*'
+pprMaybeTy sty (Just ty) = pprParendType sty ty
+\end{code}
+
+This somewhat sleazy interface is used when printing out Core syntax
+(see PprCore):
+\begin{code}
+pprType_Internal sty tvs ppr_tv uvs ppr_uv ty
+ = ppr_ty sty (VE tvs ppr_tv uvs ppr_uv) tOP_PREC ty
+\end{code}
+
+\begin{code}
+ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => PprStyle -> VarEnv tyvar uvar -> Int
+ -> GenType tyvar uvar
+ -> Pretty
+
+ppr_ty sty env ctxt_prec (TyVarTy tyvar)
+ = ppr_tyvar env tyvar
+
+ppr_ty sty env ctxt_prec (TyConTy tycon usage)
+ = ppr sty tycon
+
+ppr_ty sty env ctxt_prec ty@(ForAllTy _ _)
+ | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty
+
+ | otherwise = ppSep [ ppPStr SLIT("_forall_"),
+ ppIntersperse pp'SP pp_tyvars,
+ ppPStr SLIT("=>"),
+ ppr_ty sty env' ctxt_prec body_ty
+ ]
+ where
+ (tyvars, body_ty) = splitForAllTy ty
+ env' = foldl add_tyvar env tyvars
+ pp_tyvars = map (ppr_tyvar env') tyvars
+
+ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty)
+ = panic "ppr_ty:ForAllUsageTy"
+
+ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _)
+ | showUserishTypes sty
+ -- Print a nice looking context (Eq a, Text b) => ...
+ = ppSep [ppBesides [ppLparen,
+ ppIntersperse pp'SP (map (ppr_dict sty env tOP_PREC) theta),
+ ppRparen],
+ ppPStr SLIT("=>"),
+ ppr_ty sty env ctxt_prec body_ty
+ ]
+ where
+ (theta, body_ty) = splitRhoTy ty
+
+ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
+ -- We fiddle the precedences passed to left/right branches,
+ -- so that right associativity comes out nicely...
+ = maybeParen ctxt_prec fUN_PREC
+ (ppCat [ppr_ty sty env fUN_PREC ty1,
+ ppPStr SLIT("->"),
+ ppr_ty sty env tOP_PREC ty2])
+
+ppr_ty sty env ctxt_prec ty@(AppTy _ _)
+ = ppr_corner sty env ctxt_prec fun_ty arg_tys
+ where
+ (fun_ty, arg_tys) = splitAppTy ty
+
+ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion)
+ -- always expand types in an interface
+ = ppr_ty PprInterface env ctxt_prec expansion
+
+ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
+ = ppBeside
+ (ppr_app sty env ctxt_prec (ppr sty tycon) tys)
+ (ifPprShowAll sty (ppCat [ppStr " {- expansion:",
+ ppr_ty sty env tOP_PREC expansion,
+ ppStr "-}"]))
+
+ppr_ty sty env ctxt_prec (DictTy clas ty usage)
+ = ppr_dict sty env ctxt_prec (clas, ty)
+
+
+-- Some help functions
+ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
+ = ASSERT(length arg_tys == 2)
+ ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
+ where
+ (ty1:ty2:_) = arg_tys
+
+ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon a) usage) arg_tys
+ = ASSERT(length arg_tys == a)
+ ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
+ where
+ arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
+
+ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
+ | tycon == listTyCon
+ = ASSERT(length arg_tys == 1)
+ ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]
+ where
+ (ty1:_) = arg_tys
+
+ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
+ = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys
+
+ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys
+ = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
+
+
+ppr_app sty env ctxt_prec pp_fun []
+ = pp_fun
+ppr_app sty env ctxt_prec pp_fun arg_tys
+ = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
+ where
+ arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys)
+
+
+ppr_dict sty env ctxt_prec (clas, ty)
+ = maybeParen ctxt_prec tYCON_PREC
+ (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty])
+\end{code}
+
+Nota Bene: we must assign print-names to the forall'd type variables
+alphabetically, with the first forall'd variable having the alphabetically
+first name. Reason: so anyone reading the type signature printed without
+explicit forall's will be able to reconstruct them in the right order.
+
+\begin{code}
+-- Entirely local to this module
+data VarEnv tyvar uvar
+ = VE [Pretty] -- Tyvar pretty names
+ (tyvar -> Pretty) -- Tyvar lookup function
+ [Pretty] -- Uvar pretty names
+ (uvar -> Pretty) -- Uvar lookup function
+
+initial_ve PprForC = VE [] (\tv -> ppChar '*')
+ [] (\tv -> ppChar '#')
+
+initial_ve sty = VE tv_pretties (ppr sty)
+ uv_pretties (ppr sty)
+ where
+ tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
+ ++
+ map (\ n -> ppBeside (ppChar 'a') (ppInt n))
+ ([0 .. ] :: [Int]) -- a0 ... aN
+
+ uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
+ ++
+ map (\ n -> ppBeside (ppChar 'u') (ppInt n))
+ ([0 .. ] :: [Int]) -- u0 ... uN
+
+
+ppr_tyvar (VE _ ppr _ _) tyvar = ppr tyvar
+ppr_uvar (VE _ _ _ ppr) uvar = ppr uvar
+
+add_tyvar ve@(VE [] _ _ _) tyvar = ve
+add_tyvar (VE (tv_pp:tv_supply') tv_ppr uv_supply uv_ppr) tyvar
+ = VE tv_supply' tv_ppr' uv_supply uv_ppr
+ where
+ tv_ppr' tv | tv==tyvar = tv_pp
+ | otherwise = tv_ppr tv
+
+add_uvar ve@(VE _ _ [] _) uvar = ve
+add_uvar (VE tv_supply tv_ppr (uv_pp:uv_supply') uv_ppr) uvar
+ = VE tv_supply tv_ppr uv_supply' uv_ppr'
+ where
+ uv_ppr' uv | uv==uvar = uv_pp
+ | otherwise = uv_ppr uv
+\end{code}
+
+@ppr_ty@ takes an @Int@ that is the precedence of the context.
+The precedence levels are:
+\begin{description}
+\item[0:] What we start with.
+\item[1:] Function application (@FunTys@).
+\item[2:] Type constructors.
+\end{description}
+
+
+\begin{code}
+tOP_PREC = (0 :: Int)
+fUN_PREC = (1 :: Int)
+tYCON_PREC = (2 :: Int)
+
+maybeParen ctxt_prec inner_prec pretty
+ | ctxt_prec < inner_prec = pretty
+ | otherwise = ppParens pretty
+
+
+-- True means types like (Eq a, Text b) => a -> b
+-- False means types like _forall_ a b => Eq a -> Text b -> a -> b
+showUserishTypes PprForUser = True
+showUserishTypes PprInterface = True
+showUserishTypes other = False
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection[TyVar]{@TyVar@}
+%* *
+%************************************************************************
+
+\begin{code}
+pprTyVar sty (TyVar uniq kind name usage)
+ = ppBesides [pp_name, pprUnique10 uniq]
+ where
+ pp_name = case name of
+ Just n -> ppr sty n
+ Nothing -> case kind of
+ TypeKind -> ppChar 'o'
+ BoxedTypeKind -> ppChar 't'
+ UnboxedTypeKind -> ppChar 'u'
+ ArrowKind _ _ -> ppChar 'a'
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[TyCon]{@TyCon@}
+%* *
+%************************************************************************
+
+ToDo; all this is suspiciously like getOccurrenceName!
+
+\begin{code}
+showTyCon :: PprStyle -> TyCon -> String
+showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
+
+pprTyCon :: PprStyle -> TyCon -> Pretty
+
+pprTyCon sty FunTyCon = ppStr "(->)"
+pprTyCon sty (TupleTyCon arity) = ppBeside (ppPStr SLIT("Tuple")) (ppInt arity)
+pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
+
+pprTyCon sty tycon@(DataTyCon uniq kind name tyvars ctxt cons derivings cv nd)
+ = case sty of
+ PprDebug -> pp_tycon_and_uniq
+ PprShowAll -> pp_tycon_and_uniq
+ _ -> pp_tycon
+ where
+ pp_tycon_and_uniq = ppBesides [pp_tycon, ppChar '.', pprUnique uniq]
+ pp_tycon = ppr sty name
+
+pprTyCon sty (SpecTyCon tc ty_maybes)
+ = ppBeside (pprTyCon sty tc)
+ (if (codeStyle sty)
+ then identToC tys_stuff
+ else ppPStr tys_stuff)
+ where
+ tys_stuff = specMaybeTysSuffix ty_maybes
+
+pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion)
+ = ppBeside (ppr sty name)
+ (ifPprShowAll sty
+ (ppCat [ ppStr " {-",
+ ppInt arity,
+ interpp'SP sty tyvars,
+ pprParendType sty expansion,
+ ppStr "-}"]))
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Class]{@Class@}
+%* *
+%************************************************************************
+
+\begin{code}
+pprClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty
+
+pprClassOp sty op = ppr_class_op sty [] op
+
+ppr_class_op sty tyvars (ClassOp op_name i ty)
+ = case sty of
+ PprForC -> pp_C
+ PprForAsm _ _ -> pp_C
+ PprInterface -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
+ PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
+ _ -> pp_user
+ where
+ pp_C = ppPStr op_name
+ pp_user = if isAvarop op_name
+ then ppBesides [ppLparen, pp_C, ppRparen]
+ else pp_C
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[]{Mumbo jumbo}
+%* *
+%************************************************************************
+
+\begin{code}
+ -- Shallowly magical; converts a type into something
+ -- vaguely close to what can be used in C identifier.
+ -- Don't forget to include the module name!!!
+getTypeString :: Type -> [FAST_STRING]
+getTypeString ty
+ | is_prelude_ty = [string]
+ | otherwise = [mod, string]
+ where
+ string = _PK_ (tidy (ppShow 1000 ppr_t))
+ ppr_t = pprType PprForC ty
+ -- PprForC expands type synonyms as it goes
+
+ (is_prelude_ty, mod)
+ = case (maybeAppTyCon ty) of
+ Nothing -> true_bottom
+ Just (tycon,_) ->
+ if fromPreludeCore tycon
+ then true_bottom
+ else (False, fst (getOrigName tycon))
+
+ true_bottom = (True, panic "getTypeString")
+
+ --------------------------------------------------
+ -- tidy: very ad-hoc
+ tidy [] = [] -- done
+
+ tidy (' ' : more)
+ = case more of
+ ' ' : _ -> tidy more
+ '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
+ other -> ' ' : tidy more
+
+ tidy (',' : more) = ',' : tidy (no_leading_sps more)
+
+ tidy (x : xs) = x : tidy xs -- catch all
+
+ no_leading_sps [] = []
+ no_leading_sps (' ':xs) = no_leading_sps xs
+ no_leading_sps other = other
+
+typeMaybeString :: Maybe Type -> [FAST_STRING]
+typeMaybeString Nothing = [SLIT("!")]
+typeMaybeString (Just t) = getTypeString t
+
+specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING
+specMaybeTysSuffix ty_maybes
+ = let
+ ty_strs = concat (map typeMaybeString ty_maybes)
+ dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
+ in
+ _CONCAT_ dotted_tys
+\end{code}
+
+========================================================
+ INTERFACE STUFF; move it out
+
+
+\begin{pseudocode}
+pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs
+ = ASSERT (null specs)
+ let
+ lookup_fn = mk_lookup_tyvar_fn sty vs
+ pp_tyvars = map lookup_fn vs
+ in
+ ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
+ ppEquals, ppr_ty sty lookup_fn tOP_PREC exp]
+
+pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings unabstract data_or_new) specs
+ = ppHang (ppCat [pp_data_or_new,
+ pprContext sty ctxt,
+ ppr sty n,
+ ppIntersperse ppSP (map lookup_fn vs)])
+ 4
+ (ppCat [pp_unabstract_condecls,
+ pp_pragma])
+ -- NB: we do not print deriving info in interfaces
+ where
+ lookup_fn = mk_lookup_tyvar_fn sty vs
+
+ pp_data_or_new = case data_or_new of
+ DataType -> ppPStr SLIT("data")
+ NewType -> ppPStr SLIT("newtype")
+
+ yes_we_print_condecls
+ = unabstract
+ && not (null cons) -- we know what they are
+ && (case (getExportFlag n) of
+ ExportAbs -> False
+ other -> True)
+
+ yes_we_print_pragma_condecls
+ = not yes_we_print_condecls
+ && not opt_OmitInterfacePragmas
+ && not (null cons)
+ && not (maybeToBool (maybePurelyLocalTyCon this_tycon))
+ {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -}
+
+ yes_we_print_pragma_specs
+ = not (null specs)
+
+ pp_unabstract_condecls
+ = if yes_we_print_condecls
+ then ppCat [ppSP, ppEquals, pp_condecls]
+ else ppNil
+
+ pp_pragma_condecls
+ = if yes_we_print_pragma_condecls
+ then pp_condecls
+ else ppNil
+
+ pp_pragma_specs
+ = if yes_we_print_pragma_specs
+ then pp_specs
+ else ppNil
+
+ pp_pragma
+ = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs)
+ then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"]
+ else ppNil
+
+ pp_condecls
+ = let
+ (c:cs) = cons
+ in
+ ppCat ((ppr_con c) : (map ppr_next_con cs))
+ where
+ ppr_con con
+ = let
+ (_, _, con_arg_tys, _) = getDataConSig con
+ in
+ ppCat [pprNonOp PprForUser con, -- the data con's name...
+ ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
+
+ ppr_next_con con = ppCat [ppChar '|', ppr_con con]
+
+ pp_specs
+ = ppBesides [ppPStr SLIT("_SPECIALIZE_ "), pp_the_list [
+ ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
+ | ty_maybes <- specs ]]
+
+ pp_the_list [p] = p
+ pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
+
+ pp_maybe Nothing = pp_NONE
+ pp_maybe (Just ty) = pprParendType sty ty
+
+ pp_NONE = ppPStr SLIT("_N_")
+
+pprTyCon PprInterface (TupleTyCon a) specs
+ = ASSERT (null specs)
+ ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ]
+
+pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs
+ = ASSERT (null specs)
+ ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ]
+
+
+
+
+
+pprIfaceClass :: (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty
+
+pprIfaceClass better_id_fn inline_env
+ (Class k n tyvar super_classes sdsels ops sels defms insts links)
+ = let
+ sdsel_infos = map (getIdInfo . better_id_fn) sdsels
+ in
+ ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
+ ppr sty n, lookup_fn tyvar,
+ if null sdsel_infos
+ || opt_OmitInterfacePragmas
+ || (any boringIdInfo sdsel_infos)
+ -- ToDo: really should be "all bor..."
+ -- but then parsing is more tedious,
+ -- and this is really as good in practice.
+ then ppNil
+ else pp_sdsel_pragmas (sdsels `zip` sdsel_infos),
+ if (null ops)
+ then ppNil
+ else ppPStr SLIT("where")],
+ ppNest 8 (ppAboves
+ [ ppr_op op (better_id_fn sel) (better_id_fn defm)
+ | (op,sel,defm) <- zip3 ops sels defms]) ]
+ where
+ lookup_fn = mk_lookup_tyvar_fn sty [tyvar]
+
+ ppr_theta :: TyVar -> [Class] -> Pretty
+ ppr_theta tv [] = ppNil
+ ppr_theta tv super_classes
+ = ppBesides [ppLparen,
+ ppIntersperse pp'SP{-'-} (map ppr_assert super_classes),
+ ppStr ") =>"]
+ where
+ ppr_assert (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv]
+
+ pp_sdsel_pragmas sdsels_and_infos
+ = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}",
+ ppIntersperse pp'SP{-'-}
+ [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info
+ | (sdsel, info) <- sdsels_and_infos ],
+ ppStr "#-}"]
+
+ ppr_op op opsel_id defm_id
+ = let
+ stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op)
+ in
+ if opt_OmitInterfacePragmas
+ then stuff
+ else ppAbove stuff
+ (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"])
+ where
+ pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)]
+ pp_defm = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)]
+\end{pseudocode}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[TyCon]{The @TyCon@ datatype}
+
+\begin{code}
+#include "HsVersions.h"
+
+module TyCon(
+ TyCon(..), -- NB: some pals need to see representation
+
+ Arity(..), ConsVisible(..), NewOrData(..),
+
+ isFunTyCon, isPrimTyCon, isVisibleDataTyCon,
+
+ mkDataTyCon,
+ mkFunTyCon,
+ mkPrimTyCon,
+ mkSpecTyCon,
+ mkTupleTyCon,
+
+ mkSynTyCon,
+
+ getTyConKind,
+ getTyConUnique,
+ getTyConTyVars,
+ getTyConDataCons,
+ getTyConDerivings,
+ getSynTyConArity,
+
+ maybeTyConSingleCon,
+ isEnumerationTyCon,
+ derivedFor
+) where
+
+CHK_Ubiq() -- debugging consistency check
+import NameLoop -- for paranoia checking
+
+import TyLoop ( Type(..), GenType,
+ Class(..), GenClass,
+ Id(..), GenId,
+ mkTupleCon, getDataConSig,
+ specMaybeTysSuffix
+ )
+
+import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar )
+import Usage ( GenUsage, Usage(..) )
+import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
+import PrelMods ( pRELUDE_BUILTIN )
+
+import Maybes
+import NameTypes ( FullName )
+import Unique ( Unique, funTyConKey, mkTupleTyConUnique )
+import Outputable
+import Pretty ( Pretty(..), PrettyRep )
+import PprStyle ( PprStyle )
+import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
+import Util ( panic, panic#, nOfThem, isIn, Ord3(..) )
+\end{code}
+
+\begin{code}
+type Arity = Int
+
+data TyCon
+ = FunTyCon -- Kind = Type -> Type -> Type
+
+ | DataTyCon Unique{-TyConKey-}
+ Kind
+ FullName
+ [TyVar]
+ [(Class,Type)] -- Its context
+ [Id] -- Its data constructors, with fully polymorphic types
+ [Class] -- Classes which have derived instances
+ ConsVisible
+ NewOrData
+
+ | TupleTyCon Arity -- just a special case of DataTyCon
+ -- Kind = BoxedTypeKind
+ -- -> ... (n times) ...
+ -- -> BoxedTypeKind
+ -- -> BoxedTypeKind
+
+ | PrimTyCon -- Primitive types; cannot be defined in Haskell
+ Unique -- Always unboxed; hence never represented by a closure
+ FullName -- Often represented by a bit-pattern for the thing
+ Kind -- itself (eg Int#), but sometimes by a pointer to
+
+ | SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#)
+ TyCon
+ [Maybe Type] -- Specialising types
+
+ -- OLD STUFF ABOUT Array types. Use SpecTyCon instead
+ -- ([PrimRep] -> PrimRep) -- a heap-allocated object (eg ArrInt#).
+ -- The primitive types Arr# and StablePtr# have
+ -- parameters (hence arity /= 0); but the rest don't.
+ -- Only arrays use the list in a non-trivial way.
+ -- Length of that list must == arity.
+
+ | SynTyCon
+ Unique
+ FullName
+ Kind
+ Arity
+ [TyVar] -- Argument type variables
+ Type -- Right-hand side, mentioning these type vars.
+ -- Acts as a template for the expansion when
+ -- the tycon is applied to some types.
+
+data ConsVisible
+ = ConsVisible -- whether or not data constructors are visible
+ | ConsInvisible -- outside their TyCon's defining module.
+
+data NewOrData
+ = NewType -- "newtype Blah ..."
+ | DataType -- "data Blah ..."
+\end{code}
+
+\begin{code}
+mkFunTyCon = FunTyCon
+mkDataTyCon = DataTyCon
+mkTupleTyCon = TupleTyCon
+mkPrimTyCon = PrimTyCon
+mkSpecTyCon = SpecTyCon
+mkSynTyCon = SynTyCon
+
+isFunTyCon FunTyCon = True
+isFunTyCon _ = False
+
+isPrimTyCon (PrimTyCon _ _ _) = True
+isPrimTyCon _ = False
+
+isVisibleDataTyCon (DataTyCon _ _ _ _ _ _ _ ConsVisible _) = True
+isVisibleDataTyCon _ = False
+\end{code}
+
+\begin{code}
+-- Special cases to avoid reconstructing lots of kinds
+kind1 = mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind
+kind2 = mkBoxedTypeKind `mkArrowKind` kind1
+
+getTyConKind :: TyCon -> Kind
+getTyConKind FunTyCon = kind2
+getTyConKind (DataTyCon _ kind _ _ _ _ _ _ _) = kind
+getTyConKind (PrimTyCon _ _ kind) = kind
+
+getTyConKind (SpecTyCon tc tys)
+ = spec (getTyConKind tc) tys
+ where
+ spec kind [] = kind
+ spec kind (Just _ : tys) = spec (resultKind kind) tys
+ spec kind (Nothing : tys) =
+ argKind kind `mkArrowKind` spec (resultKind kind) tys
+
+getTyConKind (TupleTyCon n)
+ = mkArrow n
+ where
+ mkArrow 0 = mkBoxedTypeKind
+ mkArrow 1 = kind1
+ mkArrow 2 = kind2
+ mkArrow n = mkBoxedTypeKind `mkArrowKind` mkArrow (n-1)
+\end{code}
+
+\begin{code}
+getTyConUnique :: TyCon -> Unique
+getTyConUnique FunTyCon = funTyConKey
+getTyConUnique (DataTyCon uniq _ _ _ _ _ _ _ _) = uniq
+getTyConUnique (TupleTyCon a) = mkTupleTyConUnique a
+getTyConUnique (PrimTyCon uniq _ _) = uniq
+getTyConUnique (SynTyCon uniq _ _ _ _ _) = uniq
+getTyConUnique (SpecTyCon _ _ ) = panic "getTyConUnique:SpecTyCon"
+\end{code}
+
+\begin{code}
+getTyConTyVars :: TyCon -> [TyVar]
+getTyConTyVars FunTyCon = [alphaTyVar,betaTyVar]
+getTyConTyVars (DataTyCon _ _ _ tvs _ _ _ _ _) = tvs
+getTyConTyVars (TupleTyCon arity) = take arity alphaTyVars
+getTyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs
+getTyConTyVars (PrimTyCon _ _ _) = panic "getTyConTyVars:PrimTyCon"
+getTyConTyVars (SpecTyCon _ _ ) = panic "getTyConTyVars:SpecTyCon"
+\end{code}
+
+\begin{code}
+getTyConDataCons :: TyCon -> [Id]
+getTyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _ _) = data_cons
+getTyConDataCons (TupleTyCon a) = [mkTupleCon a]
+\end{code}
+
+\begin{code}
+getTyConDerivings :: TyCon -> [Class]
+getTyConDerivings (DataTyCon _ _ _ _ _ _ derivs _ _) = derivs
+\end{code}
+
+\begin{code}
+getSynTyConArity :: TyCon -> Maybe Arity
+getSynTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
+getSynTyConArity other = Nothing
+\end{code}
+
+\begin{code}
+maybeTyConSingleCon :: TyCon -> Maybe Id
+maybeTyConSingleCon (TupleTyCon arity) = Just (mkTupleCon arity)
+maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _ _) = Just c
+maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _ _) = 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 (getDataConSig con) of { (_,_, arg_tys, _) ->
+ null arg_tys }
+\end{code}
+
+@derivedFor@ reports if we have an {\em obviously}-derived instance
+for the given class/tycon. Of course, you might be deriving something
+because it a superclass of some other obviously-derived class --- this
+function doesn't deal with that.
+
+ToDo: what about derivings for specialised tycons !!!
+
+\begin{code}
+derivedFor :: Class -> TyCon -> Bool
+derivedFor clas (DataTyCon _ _ _ _ _ _ derivs _ _) = isIn "derivedFor" clas derivs
+derivedFor clas something_weird = False
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[TyCon-instances]{Instance declarations for @TyCon@}
+%* *
+%************************************************************************
+
+@TyCon@s are compared by comparing their @Unique@s.
+
+The strictness analyser needs @Ord@. It is a lexicographic order with
+the property @(a<=b) || (b<=a)@.
+
+\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)
+
+instance Eq TyCon where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord TyCon 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}
+instance NamedThing TyCon where
+ getExportFlag tc = case get_name tc of
+ Nothing -> NotExported
+ Just name -> getExportFlag name
+
+
+ isLocallyDefined tc = case get_name tc of
+ Nothing -> False
+ Just name -> isLocallyDefined name
+
+ getOrigName FunTyCon = (pRELUDE_BUILTIN, SLIT("(->)"))
+ getOrigName (TupleTyCon a) = (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ show a))
+ getOrigName (SpecTyCon tc tys) = let (m,n) = getOrigName tc in
+ (m, n _APPEND_ specMaybeTysSuffix tys)
+ getOrigName other_tc = getOrigName (expectJust "tycon1" (get_name other_tc))
+
+ getOccurrenceName FunTyCon = SLIT("(->)")
+ getOccurrenceName (TupleTyCon 0) = SLIT("()")
+ getOccurrenceName (TupleTyCon a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
+ getOccurrenceName (SpecTyCon tc tys)= getOccurrenceName tc _APPEND_ specMaybeTysSuffix tys
+ getOccurrenceName other_tc = getOccurrenceName (expectJust "tycon2" (get_name other_tc))
+
+ getInformingModules tc = case get_name tc of
+ Nothing -> panic "getInformingModule:TyCon"
+ Just name -> getInformingModules name
+
+ getSrcLoc tc = case get_name tc of
+ Nothing -> mkBuiltinSrcLoc
+ Just name -> getSrcLoc name
+
+ getItsUnique tycon = getTyConUnique tycon
+
+ fromPreludeCore tc = case get_name tc of
+ Nothing -> True
+ Just name -> fromPreludeCore name
+\end{code}
+
+Emphatically un-exported:
+
+\begin{code}
+get_name (DataTyCon _ _ n _ _ _ _ _ _) = Just n
+get_name (PrimTyCon _ n _) = Just n
+get_name (SpecTyCon tc _) = get_name tc
+get_name (SynTyCon _ n _ _ _ _) = Just n
+get_name other = Nothing
+\end{code}
+
--- /dev/null
+Breaks the TyCon/types loop and the types/Id loop.
+
+\begin{code}
+interface TyLoop where
+
+import PreludePS(_PackedString)
+import PreludeStdIO ( Maybe )
+import Unique ( Unique )
+
+import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
+ getDataConSig, getInstantiatedDataConSig )
+import PprType ( specMaybeTysSuffix )
+import NameTypes ( FullName )
+import TyCon ( TyCon )
+import TyVar ( GenTyVar, TyVar )
+import Type ( GenType, Type )
+import Usage ( GenUsage )
+import Class ( Class, GenClass )
+
+data GenId ty
+data GenType tyvar uvar
+data GenTyVar uvar
+data GenClass tyvar uvar
+data GenUsage u
+
+type Type = GenType (GenTyVar (GenUsage Unique)) Unique
+type TyVar = GenTyVar (GenUsage Unique)
+type Class = GenClass (GenTyVar (GenUsage Unique)) Unique
+type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
+
+-- Needed in TyCon
+mkTupleCon :: Int -> Id
+getDataConSig :: Id -> ([TyVar], [(Class, Type)], [Type], TyCon)
+specMaybeTysSuffix :: [Maybe Type] -> _PackedString
+instance Eq (GenClass a b)
+
+-- Needed in Type
+getInstantiatedDataConSig :: Id -> [Type] -> ([Type],[Type],Type)
+
+-- Needed in TysWiredIn
+data StrictnessMark = MarkedStrict | NotMarkedStrict
+mkDataCon :: Unique -> FullName -> [StrictnessMark]
+ -> [TyVar] -> [(Class,Type)] -> [Type] -> TyCon
+ -> Id
+\end{code}
--- /dev/null
+
+\begin{code}
+module AllTypes(
+ TyCon, Arity(..),
+ Class, ClassOp,
+ GenTyVar, GenType, Type,
+ Id,
+
+ -- Functions which are, alas, necessary to break loops
+ mkTupleCon, -- Used in TyCon
+
+
+ Kind, -- Not necessary to break loops, but useful
+ GenUsage -- to get when importing AllTypes
+) where
+
+import TyCon ( TyCon, Arity(..) )
+import Type ( GenTyVar, TyVar(..), GenType, Type(..) )
+import Class ( Class,ClassOp )
+import Id ( Id, mkTupleCon )
+import Kind ( Kind )
+import Usage ( GenUsage, Usage(..) )
+\end{code}
--- /dev/null
+\begin{code}
+#include "HsVersions.h"
+
+module TyVar (
+ GenTyVar(..), TyVar(..),
+ mkTyVar,
+ getTyVarKind, -- TyVar -> Kind
+
+ alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
+
+ -- We also export "environments" keyed off of
+ -- TyVars and "sets" containing TyVars:
+ TyVarEnv(..),
+ nullTyVarEnv, mkTyVarEnv, addOneToTyVarEnv,
+ growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv,
+
+ GenTyVarSet(..), TyVarSet(..),
+ emptyTyVarSet, singletonTyVarSet, unionTyVarSets, tyVarListToSet,
+ tyVarSetToList, elementOfTyVarSet, minusTyVarSet, isEmptyTyVarSet
+ ) where
+
+CHK_Ubiq() -- debugging consistency check
+import IdLoop -- for paranoia checking
+
+-- friends
+import Usage ( GenUsage, Usage(..), usageOmega )
+import Kind ( Kind, mkBoxedTypeKind )
+
+-- others
+import UniqSet ( uniqSetToList, emptyUniqSet, singletonUniqSet, minusUniqSet,
+ unionUniqSets, elementOfUniqSet, isEmptyUniqSet, mkUniqSet,
+ UniqSet(..) )
+import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
+ plusUFM, sizeUFM, UniqFM )
+import Maybes ( Maybe(..) )
+import NameTypes ( ShortName )
+import Pretty ( Pretty(..), PrettyRep, ppBeside, ppPStr )
+import PprStyle ( PprStyle )
+import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) )
+import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
+import Unique ( showUnique, mkAlphaTyVarUnique, Unique )
+import Util ( panic, Ord3(..) )
+\end{code}
+
+\begin{code}
+data GenTyVar flexi_slot
+ = TyVar
+ Unique
+ Kind
+ (Maybe ShortName) -- User name (if any)
+ flexi_slot -- Extra slot used during type and usage
+ -- inference, and to contain usages.
+
+type TyVar = GenTyVar Usage -- Usage slot makes sense only if Kind = Type
+\end{code}
+
+
+Simple construction and analysis functions
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+mkTyVar :: ShortName -> Unique -> Kind -> TyVar
+mkTyVar name uniq kind = TyVar uniq
+ kind
+ (Just name)
+ usageOmega
+
+getTyVarKind :: GenTyVar flexi -> Kind
+getTyVarKind (TyVar _ kind _ _) = kind
+\end{code}
+
+
+Fixed collection of type variables
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing usageOmega
+ | u <- map mkAlphaTyVarUnique [1..] ]
+
+(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars
+\end{code}
+
+
+Environments
+~~~~~~~~~~~~
+\begin{code}
+type TyVarEnv elt = UniqFM elt
+
+nullTyVarEnv :: TyVarEnv a
+mkTyVarEnv :: [(GenTyVar flexi, a)] -> TyVarEnv a
+addOneToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a
+growTyVarEnvList :: TyVarEnv a -> [(GenTyVar flexi, a)] -> TyVarEnv a
+isNullTyVarEnv :: TyVarEnv a -> Bool
+lookupTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> Maybe a
+
+nullTyVarEnv = emptyUFM
+mkTyVarEnv = listToUFM
+addOneToTyVarEnv = addToUFM
+lookupTyVarEnv = lookupUFM
+
+growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
+isNullTyVarEnv env = sizeUFM env == 0
+\end{code}
+
+Sets
+~~~~
+\begin{code}
+type GenTyVarSet flexi = UniqSet (GenTyVar flexi)
+type TyVarSet = UniqSet TyVar
+
+emptyTyVarSet :: GenTyVarSet flexi
+unionTyVarSets :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
+tyVarSetToList :: GenTyVarSet flexi -> [GenTyVar flexi]
+singletonTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi
+elementOfTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi -> Bool
+minusTyVarSet :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi
+isEmptyTyVarSet :: GenTyVarSet flexi -> Bool
+tyVarListToSet :: [GenTyVar flexi] -> GenTyVarSet flexi
+
+emptyTyVarSet = emptyUniqSet
+singletonTyVarSet = singletonUniqSet
+unionTyVarSets = unionUniqSets
+tyVarSetToList = uniqSetToList
+elementOfTyVarSet = elementOfUniqSet
+minusTyVarSet = minusUniqSet
+isEmptyTyVarSet = isEmptyUniqSet
+tyVarListToSet = mkUniqSet
+\end{code}
+
+Instance delarations
+~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+instance Eq (GenTyVar a) where
+ (TyVar u1 _ _ _) == (TyVar u2 _ _ _) = u1 == u2
+
+instance Ord3 (GenTyVar a) where
+ cmp (TyVar u1 _ _ _) (TyVar u2 _ _ _) = u1 `cmp` u2
+
+instance NamedThing (GenTyVar a) where
+ getExportFlag (TyVar _ _ _ _) = NotExported
+ isLocallyDefined (TyVar _ _ _ _) = True
+
+ getOrigName (TyVar _ _ (Just n) _) = getOrigName n
+ getOrigName (TyVar u _ _ _) = (panic "getOrigName:TyVar",
+ showUnique u)
+ getOccurrenceName (TyVar _ _ (Just n) _) = getOccurrenceName n
+ getOccurrenceName (TyVar u _ _ _) = showUnique u
+
+ getSrcLoc (TyVar _ _ (Just n) _) = getSrcLoc n
+ getSrcLoc (TyVar _ _ _ _) = mkUnknownSrcLoc
+ fromPreludeCore (TyVar _ _ _ _) = False
+
+ getItsUnique (TyVar u _ _ _) = u
+
+\end{code}
--- /dev/null
+\begin{code}
+#include "HsVersions.h"
+
+module Type (
+ GenType(..), Type(..), TauType(..),
+ mkTyVarTy, getTyVar, getTyVar_maybe, isTyVarTy,
+ mkAppTy, mkAppTys, splitAppTy,
+ mkFunTy, mkFunTys, splitFunTy, getFunTy_maybe,
+ mkTyConTy, getTyCon_maybe, applyTyCon,
+ mkSynTy,
+ mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
+ mkForAllUsageTy, getForAllUsageTy,
+ applyTy,
+
+ isPrimType,
+
+ RhoType(..), SigmaType(..), ThetaType(..),
+ mkDictTy,
+ mkRhoTy, splitRhoTy,
+ mkSigmaTy, splitSigmaTy,
+
+ maybeAppTyCon, getAppTyCon,
+ maybeAppDataTyCon, getAppDataTyCon,
+ maybeBoxedPrimType,
+
+ matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta,
+
+ instantiateTy,instantiateUsage,
+
+ isTauTy,
+
+ tyVarsOfType, tyVarsOfTypes, getTypeKind
+
+
+) where
+
+import Ubiq
+import IdLoop -- for paranoia checking
+import TyLoop -- for paranoia checking
+import PrelLoop -- for paranoia checking
+
+-- friends:
+import Class ( getClassSig, getClassOpLocalType, GenClass{-instances-} )
+import Kind ( mkBoxedTypeKind, resultKind )
+import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon,
+ getTyConKind, getTyConDataCons, TyCon )
+import TyVar ( getTyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
+ emptyTyVarSet, unionTyVarSets, minusTyVarSet,
+ singletonTyVarSet, nullTyVarEnv, lookupTyVarEnv,
+ addOneToTyVarEnv, TyVarEnv(..) )
+import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..),
+ nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
+ eqUsage )
+
+-- others
+import Util ( thenCmp, zipEqual, panic, panic#, assertPanic,
+ Ord3(..){-instances-}
+ )
+\end{code}
+
+Data types
+~~~~~~~~~~
+
+\begin{code}
+type Type = GenType TyVar UVar -- Used after typechecker
+
+data GenType tyvar uvar -- Parameterised over type and usage variables
+ = TyVarTy tyvar
+
+ | AppTy
+ (GenType tyvar uvar)
+ (GenType tyvar uvar)
+
+ | TyConTy -- Constants of a specified kind
+ TyCon
+ (GenUsage uvar) -- Usage gives uvar of the full application,
+ -- iff the full application is of kind Type
+ -- c.f. the Usage field in TyVars
+
+ | SynTy -- Synonyms must be saturated, and contain their expansion
+ TyCon -- Must be a SynTyCon
+ [GenType tyvar uvar]
+ (GenType tyvar uvar) -- Expansion!
+
+ | ForAllTy
+ tyvar
+ (GenType tyvar uvar) -- TypeKind
+
+ | ForAllUsageTy
+ uvar -- Quantify over this
+ [uvar] -- Bounds; the quantified var must be
+ -- less than or equal to all these
+ (GenType tyvar uvar)
+
+ -- Two special cases that save a *lot* of administrative
+ -- overhead:
+
+ | FunTy -- BoxedTypeKind
+ (GenType tyvar uvar) -- Both args are of TypeKind
+ (GenType tyvar uvar)
+ (GenUsage uvar)
+
+ | DictTy -- TypeKind
+ Class -- Class
+ (GenType tyvar uvar) -- Arg has kind TypeKind
+ (GenUsage uvar)
+\end{code}
+
+\begin{code}
+type RhoType = Type
+type TauType = Type
+type ThetaType = [(Class, Type)]
+type SigmaType = Type
+\end{code}
+
+
+Expand abbreviations
+~~~~~~~~~~~~~~~~~~~~
+Removes just the top level of any abbreviations.
+
+\begin{code}
+expandTy :: Type -> Type -- Restricted to Type due to Dict expansion
+
+expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
+expandTy (SynTy _ _ t) = expandTy t
+expandTy (DictTy clas ty u)
+ = case all_arg_tys of
+
+ [arg_ty] -> expandTy arg_ty -- just the <whatever> itself
+
+ -- The extra expandTy is to make sure that
+ -- the result isn't still a dict, which it might be
+ -- if the original guy was a dict with one superdict and
+ -- no methods!
+
+ other -> ASSERT(not (null all_arg_tys))
+ foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys
+
+ -- A tuple of 'em
+ -- Note: length of all_arg_tys can be 0 if the class is
+ -- _CCallable, _CReturnable (and anything else
+ -- *really weird* that the user writes).
+ where
+ (tyvar, super_classes, ops) = getClassSig clas
+ super_dict_tys = map mk_super_ty super_classes
+ class_op_tys = map mk_op_ty ops
+ all_arg_tys = super_dict_tys ++ class_op_tys
+ mk_super_ty sc = DictTy sc ty usageOmega
+ mk_op_ty op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op)
+
+expandTy ty = ty
+\end{code}
+
+Simple construction and analysis functions
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+mkTyVarTy :: t -> GenType t u
+mkTyVarTy = TyVarTy
+-- could we use something for (map mkTyVarTy blahs) ?? WDP
+
+getTyVar :: String -> GenType t u -> t
+getTyVar msg (TyVarTy tv) = tv
+getTyVar msg (SynTy _ _ t) = getTyVar msg t
+getTyVar msg other = error ("getTyVar" ++ msg)
+
+getTyVar_maybe :: GenType t u -> Maybe t
+getTyVar_maybe (TyVarTy tv) = Just tv
+getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
+getTyVar_maybe other = Nothing
+
+isTyVarTy :: GenType t u -> Bool
+isTyVarTy (TyVarTy tv) = True
+isTyVarTy (SynTy _ _ t) = isTyVarTy t
+isTyVarTy other = False
+\end{code}
+
+\begin{code}
+mkAppTy = AppTy
+
+mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
+mkAppTys t ts = foldl AppTy t ts
+
+splitAppTy :: GenType t u -> (GenType t u, [GenType t u])
+splitAppTy t = go t []
+ where
+ go (AppTy t arg) ts = go t (arg:ts)
+ go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
+ go (SynTy _ _ t) ts = go t ts
+ go t ts = (t,ts)
+\end{code}
+
+\begin{code}
+-- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
+mkFunTy arg res = FunTy arg res usageOmega
+
+mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
+mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
+
+getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
+getFunTy_maybe (FunTy arg result _) = Just (arg,result)
+getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
+ | isFunTyCon tycon = Just (arg, res)
+getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t
+getFunTy_maybe other = Nothing
+
+splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
+splitFunTy t = go t []
+ where
+ go (FunTy arg res _) ts = go res (arg:ts)
+ go (AppTy (AppTy (TyConTy tycon _) arg) res) ts
+ | isFunTyCon tycon
+ = go res (arg:ts)
+ go (SynTy _ _ t) ts
+ = go t ts
+ go t ts
+ = (reverse ts, t)
+\end{code}
+
+\begin{code}
+-- NB applyTyCon puts in usageOmega, for now at least
+mkTyConTy tycon = TyConTy tycon usageOmega
+
+applyTyCon :: TyCon -> [GenType t u] -> GenType t u
+applyTyCon tycon tys = foldl AppTy (TyConTy tycon usageOmega) tys
+
+getTyCon_maybe :: GenType t u -> Maybe TyCon
+getTyCon_maybe (TyConTy tycon _) = Just tycon
+getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t
+getTyCon_maybe other_ty = Nothing
+\end{code}
+
+\begin{code}
+mkSynTy syn_tycon tys
+ = SynTy syn_tycon tys (panic "Type.mkSynTy:expansion")
+\end{code}
+
+Tau stuff
+~~~~~~~~~
+\begin{code}
+isTauTy :: GenType t u -> Bool
+isTauTy (TyVarTy v) = True
+isTauTy (TyConTy _ _) = True
+isTauTy (AppTy a b) = isTauTy a && isTauTy b
+isTauTy (FunTy a b _) = isTauTy a && isTauTy b
+isTauTy (SynTy _ _ ty) = isTauTy ty
+isTauTy other = False
+\end{code}
+
+Rho stuff
+~~~~~~~~~
+NB mkRhoTy and mkDictTy put in usageOmega, for now at least
+
+\begin{code}
+mkDictTy :: Class -> GenType t u -> GenType t u
+mkDictTy clas ty = DictTy clas ty usageOmega
+
+mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
+mkRhoTy theta ty =
+ foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
+
+splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
+splitRhoTy t =
+ go t []
+ where
+ go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
+ go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
+ | isFunTyCon tycon
+ = go r ((c,t):ts)
+ go (SynTy _ _ t) ts = go t ts
+ go t ts = (reverse ts, t)
+\end{code}
+
+
+Forall stuff
+~~~~~~~~~~~~
+\begin{code}
+mkForAllTy = ForAllTy
+
+mkForAllTys :: [t] -> GenType t u -> GenType t u
+mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
+
+getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
+getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t
+getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
+getForAllTy_maybe _ = Nothing
+
+splitForAllTy :: GenType t u-> ([t], GenType t u)
+splitForAllTy t = go t []
+ where
+ go (ForAllTy tv t) tvs = go t (tv:tvs)
+ go (SynTy _ _ t) tvs = go t tvs
+ go t tvs = (reverse tvs, t)
+\end{code}
+
+\begin{code}
+mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
+mkForAllUsageTy = ForAllUsageTy
+
+getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
+getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
+getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
+getForAllUsageTy _ = Nothing
+\end{code}
+
+Applied tycons (includes FunTyCons)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+maybeAppTyCon
+ :: GenType tyvar uvar
+ -> Maybe (TyCon, -- the type constructor
+ [GenType tyvar uvar]) -- types to which it is applied
+
+maybeAppTyCon ty
+ = case (getTyCon_maybe app_ty) of
+ Nothing -> Nothing
+ Just tycon -> Just (tycon, arg_tys)
+ where
+ (app_ty, arg_tys) = splitAppTy ty
+
+
+getAppTyCon
+ :: GenType tyvar uvar
+ -> (TyCon, -- the type constructor
+ [GenType tyvar uvar]) -- types to which it is applied
+
+getAppTyCon ty
+ = case maybeAppTyCon ty of
+ Just stuff -> stuff
+#ifdef DEBUG
+ Nothing -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
+#endif
+\end{code}
+
+Applied data tycons (give back constrs)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+maybeAppDataTyCon
+ :: GenType tyvar uvar
+ -> Maybe (TyCon, -- the type constructor
+ [GenType tyvar uvar], -- types to which it is applied
+ [Id]) -- its family of data-constructors
+
+maybeAppDataTyCon ty
+ = case (getTyCon_maybe app_ty) of
+ Nothing -> Nothing
+ Just tycon | isFunTyCon tycon
+ -> Nothing
+ | otherwise
+ -> Just (tycon, arg_tys, getTyConDataCons tycon)
+ where
+ (app_ty, arg_tys) = splitAppTy ty
+
+
+getAppDataTyCon
+ :: GenType tyvar uvar
+ -> (TyCon, -- the type constructor
+ [GenType tyvar uvar], -- types to which it is applied
+ [Id]) -- its family of data-constructors
+
+getAppDataTyCon ty
+ = case maybeAppDataTyCon ty of
+ Just stuff -> stuff
+#ifdef DEBUG
+ Nothing -> panic "Type.getAppDataTyCon" -- (ppr PprShowAll ty)
+#endif
+
+
+maybeBoxedPrimType :: Type -> Maybe (Id, Type)
+
+maybeBoxedPrimType ty
+ = case (maybeAppDataTyCon ty) of -- Data type,
+ Just (tycon, tys_applied, [data_con]) -- with exactly one constructor
+ -> case (getInstantiatedDataConSig data_con tys_applied) of
+ (_, [data_con_arg_ty], _) -- Applied to exactly one type,
+ | isPrimType data_con_arg_ty -- which is primitive
+ -> Just (data_con, data_con_arg_ty)
+ other_cases -> Nothing
+ other_cases -> Nothing
+\end{code}
+
+\begin{code}
+splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
+splitSigmaTy ty =
+ (tyvars, theta, tau)
+ where
+ (tyvars,rho) = splitForAllTy ty
+ (theta,tau) = splitRhoTy rho
+
+mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
+\end{code}
+
+
+Finding the kind of a type
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+getTypeKind :: GenType (GenTyVar any) u -> Kind
+getTypeKind (TyVarTy tyvar) = getTyVarKind tyvar
+getTypeKind (TyConTy tycon usage) = getTyConKind tycon
+getTypeKind (SynTy _ _ ty) = getTypeKind ty
+getTypeKind (FunTy fun arg _) = mkBoxedTypeKind
+getTypeKind (DictTy clas arg _) = mkBoxedTypeKind
+getTypeKind (AppTy fun arg) = resultKind (getTypeKind fun)
+getTypeKind (ForAllTy _ _) = mkBoxedTypeKind
+getTypeKind (ForAllUsageTy _ _ _) = mkBoxedTypeKind
+\end{code}
+
+
+Free variables of a type
+~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
+
+tyVarsOfType (TyVarTy tv) = singletonTyVarSet tv
+tyVarsOfType (TyConTy tycon usage) = emptyTyVarSet
+tyVarsOfType (SynTy _ tys ty) = tyVarsOfTypes tys
+tyVarsOfType (FunTy arg res _) = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
+tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
+tyVarsOfType (DictTy clas ty _) = tyVarsOfType ty
+tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` singletonTyVarSet tyvar
+tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty
+
+tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
+tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
+\end{code}
+
+
+Instantiating a type
+~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+applyTy :: Eq t => GenType t u -> GenType t u -> GenType t u
+applyTy (SynTy _ _ fun) arg = applyTy fun arg
+applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
+applyTy other arg = panic "applyTy"
+
+instantiateTy :: Eq t => [(t, GenType t u)] -> GenType t u -> GenType t u
+instantiateTy tenv ty
+ = go ty
+ where
+ go (TyVarTy tv) = case [ty | (tv',ty) <- tenv, tv==tv'] of
+ [] -> TyVarTy tv
+ (ty:_) -> ty
+ go ty@(TyConTy tycon usage) = ty
+ go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
+ go (FunTy arg res usage) = FunTy (go arg) (go res) usage
+ go (AppTy fun arg) = AppTy (go fun) (go arg)
+ go (DictTy clas ty usage) = DictTy clas (go ty) usage
+ go (ForAllTy tv ty) = ASSERT(null tv_bound)
+ ForAllTy tv (go ty)
+ where
+ tv_bound = [() | (tv',_) <- tenv, tv==tv']
+
+ go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty)
+
+instantiateUsage
+ :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
+instantiateUsage = error "instantiateUsage: not implemented"
+\end{code}
+
+\begin{code}
+isPrimType :: GenType tyvar uvar -> Bool
+isPrimType (AppTy ty _) = isPrimType ty
+isPrimType (SynTy _ _ ty) = isPrimType ty
+isPrimType (TyConTy tycon _) = isPrimTyCon tycon
+isPrimType _ = False
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Matching on types}
+%* *
+%************************************************************************
+
+Matching is a {\em unidirectional} process, matching a type against a
+template (which is just a type with type variables in it). The
+matcher assumes that there are no repeated type variables in the
+template, so that it simply returns a mapping of type variables to
+types. It also fails on nested foralls.
+
+@matchTys@ matches corresponding elements of a list of templates and
+types.
+
+\begin{code}
+matchTy :: GenType t1 u1 -- Template
+ -> GenType t2 u2 -- Proposed instance of template
+ -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
+
+matchTys :: [GenType t1 u1] -- Templates
+ -> [GenType t2 u2] -- Proposed instance of template
+ -> Maybe [(t1,GenType t2 u2)] -- Matching substitution
+
+matchTy ty1 ty2 = match [] [] ty1 ty2
+matchTys tys1 tys2 = match' [] (zipEqual tys1 tys2)
+\end{code}
+
+@match@ is the main function.
+
+\begin{code}
+match :: [(t1, GenType t2 u2)] -- r, the accumulating result
+ -> [(GenType t1 u1, GenType t2 u2)] -- w, the work list
+ -> GenType t1 u1 -> GenType t2 u2 -- Current match pair
+ -> Maybe [(t1, GenType t2 u2)]
+
+match r w (TyVarTy v) ty = match' ((v,ty) : r) w
+match r w (FunTy fun1 arg1 _) (FunTy fun2 arg2 _) = match r ((fun1,fun2):w) arg1 arg2
+match r w (AppTy fun1 arg1) (AppTy fun2 arg2) = match r ((fun1,fun2):w) arg1 arg2
+match r w (TyConTy con1 _) (TyConTy con2 _) | con1 == con2 = match' r w
+match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
+match r w (SynTy _ _ ty1) ty2 = match r w ty1 ty2
+match r w ty1 (SynTy _ _ ty2) = match r w ty1 ty2
+
+ -- With type synonyms, we have to be careful for the exact
+ -- same reasons as in the unifier. Please see the
+ -- considerable commentary there before changing anything
+ -- here! (WDP 95/05)
+
+-- Catch-all fails
+match _ _ _ _ = Nothing
+
+match' r [] = Just r
+match' r ((ty1,ty2):w) = match r w ty1 ty2
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Equality on types}
+%* *
+%************************************************************************
+
+The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
+and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
+dictionaries or polymorphic types). The function eqTy has a more
+specific type, but does the `right thing' for all types.
+
+\begin{code}
+eqSimpleTheta :: (Eq t,Eq u) =>
+ [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
+
+eqSimpleTheta [] [] = True
+eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
+ c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
+eqSimpleTheta other1 other2 = False
+\end{code}
+
+\begin{code}
+eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
+
+(TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
+ tv1 == tv2
+(AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) =
+ f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
+(TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
+ tc1 == tc2 && u1 == u2
+
+(FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
+ f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
+(FunTy f1 a1 u1) `eqSimpleTy` t2 =
+ -- Expand t1 just in case t2 matches that version
+ (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
+t1 `eqSimpleTy` (FunTy f2 a2 u2) =
+ -- Expand t2 just in case t1 matches that version
+ t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
+
+(SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
+ (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
+ || t1 `eqSimpleTy` t2
+(SynTy _ _ t1) `eqSimpleTy` t2 =
+ t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
+t1 `eqSimpleTy` (SynTy _ _ t2) =
+ t1 `eqSimpleTy` t2 -- Expand the abbrevation and try again
+
+(DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
+_ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
+
+(ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
+_ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
+
+(ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
+_ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
+
+_ `eqSimpleTy` _ = False
+\end{code}
+
+Types are ordered so we can sort on types in the renamer etc. DNT: Since
+this class is also used in CoreLint and other such places, we DO expand out
+Fun/Syn/Dict types (if necessary).
+
+\begin{code}
+eqTy :: Type -> Type -> Bool
+
+eqTy t1 t2 =
+ eq nullTyVarEnv nullUVarEnv t1 t2
+ where
+ eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
+ tv1 == tv2 ||
+ case (lookupTyVarEnv tve tv1) of
+ Just tv -> tv == tv2
+ Nothing -> False
+ eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
+ eq tve uve f1 f2 && eq tve uve a1 a2
+ eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
+ tc1 == tc2 && eqUsage uve u1 u2
+
+ eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
+ eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
+ eq tve uve (FunTy f1 a1 u1) t2 =
+ -- Expand t1 just in case t2 matches that version
+ eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
+ eq tve uve t1 (FunTy f2 a2 u2) =
+ -- Expand t2 just in case t1 matches that version
+ eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
+
+ eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2) =
+ c1 == c2 && eq tve uve t1 t2 && eqUsage uve u1 u2
+ eq tve uve t1@(DictTy _ _ _) t2 =
+ eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again
+ eq tve uve t1 t2@(DictTy _ _ _) =
+ eq tve uve t1 (expandTy t2) -- Expand the dictionary and try again
+
+ eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
+ (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
+ || eq tve uve t1 t2
+ eq tve uve (SynTy _ _ t1) t2 =
+ eq tve uve t1 t2 -- Expand the abbrevation and try again
+ eq tve uve t1 (SynTy _ _ t2) =
+ eq tve uve t1 t2 -- Expand the abbrevation and try again
+
+ eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
+ eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
+ eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
+ eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
+
+ eq _ _ _ _ = False
+
+ eqBounds uve [] [] = True
+ eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
+ eqBounds uve _ _ = False
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[Usage]{The @Usage@ datatype}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Usage (
+ GenUsage, Usage(..), UVar(..), UVarEnv(..),
+ usageOmega, pprUVar, duffUsage,
+ nullUVarEnv, mkUVarEnv, addOneToUVarEnv,
+ growUVarEnvList, isNullUVarEnv, lookupUVarEnv,
+ eqUVar, eqUsage
+) where
+
+import Ubiq
+import Pretty ( Pretty(..), PrettyRep, ppPStr, ppBeside )
+import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
+ plusUFM, sizeUFM, UniqFM )
+import Unique ( Unique{-instances-} )
+\end{code}
+
+\begin{code}
+data GenUsage uvar
+ = UsageVar uvar
+ | UsageOne
+ | UsageOmega
+
+type UVar = Unique
+type Usage = GenUsage UVar
+
+usageOmega = UsageOmega
+
+duffUsage :: GenUsage uvar
+duffUsage = error "Usage of non-Type kind doesn't make sense"
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Environments}
+%* *
+%************************************************************************
+
+\begin{code}
+type UVarEnv a = UniqFM a
+
+nullUVarEnv :: UVarEnv a
+mkUVarEnv :: [(UVar, a)] -> UVarEnv a
+addOneToUVarEnv :: UVarEnv a -> UVar -> a -> UVarEnv a
+growUVarEnvList :: UVarEnv a -> [(UVar, a)] -> UVarEnv a
+isNullUVarEnv :: UVarEnv a -> Bool
+lookupUVarEnv :: UVarEnv a -> UVar -> Maybe a
+
+nullUVarEnv = emptyUFM
+mkUVarEnv = listToUFM
+addOneToUVarEnv = addToUFM
+lookupUVarEnv = lookupUFM
+
+growUVarEnvList env pairs = plusUFM env (listToUFM pairs)
+isNullUVarEnv env = sizeUFM env == 0
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Equality on usages}
+%* *
+%************************************************************************
+
+Equaltity (with respect to an environment mapping usage variables
+to equivalent usage variables).
+
+\begin{code}
+eqUVar :: UVarEnv UVar -> UVar -> UVar -> Bool
+eqUVar uve u1 u2 =
+ u1 == u2 ||
+ case lookupUVarEnv uve u1 of
+ Just u -> u == u2
+ Nothing -> False
+
+eqUsage :: UVarEnv UVar -> Usage -> Usage -> Bool
+eqUsage uve (UsageVar u1) (UsageVar u2) = eqUVar uve u1 u2
+eqUsage uve UsageOne UsageOne = True
+eqUsage uve UsageOmega UsageOmega = True
+eqUsage _ _ _ = False
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Instances}
+%* *
+%************************************************************************
+
+\begin{code}
+instance Eq u => Eq (GenUsage u) where
+ (UsageVar u1) == (UsageVar u2) = u1 == u2
+ UsageOne == UsageOne = True
+ UsageOmega == UsageOmega = True
+ _ == _ = False
+\end{code}
+
+\begin{code}
+instance Outputable uvar => Outputable (GenUsage uvar) where
+ ppr sty UsageOne = ppPStr SLIT("UsageOne")
+ ppr sty UsageOmega = ppPStr SLIT("UsageOmega")
+ ppr sty (UsageVar u) = pprUVar sty u
+
+pprUVar sty u = ppBeside (ppPStr SLIT("u")) (ppr sty u)
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[Argv]{@Argv@: direct (non-standard) access to command-line arguments}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Argv ( argv ) where
+
+import PreludeGlaST ( indexAddrOffAddr )
+
+CHK_Ubiq() -- debugging consistency check
+
+argv :: [FAST_STRING]
+argv = unpackArgv ``prog_argv'' (``prog_argc''::Int)
+
+unpackArgv :: _Addr -> Int -> [FAST_STRING] -- argv[1 .. argc-1]
+
+unpackArgv argv argc = unpack 1
+ where
+ unpack :: Int -> [FAST_STRING]
+ unpack n
+ = if (n >= argc)
+ then ([] :: [FAST_STRING])
+ else case (indexAddrOffAddr argv n) of { item ->
+ _packCString item : unpack (n + 1)
+ }
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Bag where
-import Outputable(Outputable)
-data Bag a
-bagToList :: Bag a -> [a]
-emptyBag :: Bag a
-filterBag :: (a -> Bool) -> Bag a -> Bag a
-isEmptyBag :: Bag a -> Bool
-listToBag :: [a] -> Bag a
-partitionBag :: (a -> Bool) -> Bag a -> (Bag a, Bag a)
-snocBag :: Bag a -> a -> Bag a
-unionBags :: Bag a -> Bag a -> Bag a
-unionManyBags :: [Bag a] -> Bag a
-unitBag :: a -> Bag a
-instance Outputable a => Outputable (Bag a)
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Bags]{@Bag@: an unordered collection with duplicates}
Bag, -- abstract type
emptyBag, unitBag, unionBags, unionManyBags,
-#if ! defined(COMPILING_GHC)
- elemBag,
-#endif
- filterBag, partitionBag,
- isEmptyBag, snocBag, listToBag, bagToList
+ elemBag, mapBag,
+ filterBag, partitionBag, concatBag, foldBag,
+ isEmptyBag, consBag, snocBag,
+ listToBag, bagToList, bagToList_append
) where
-#if defined(COMPILING_GHC)
-import Id ( Id )
-import Outputable
+#ifdef COMPILING_GHC
+import Ubiq{-uitous-}
+
+import Outputable ( interpp'SP )
import Pretty
-import Util
#endif
data Bag a
= EmptyBag
| UnitBag a
| TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least
- -- one branch is non-empty.
+ -- one branch is non-empty
+ | ListBag [a] -- The list is non-empty
| ListOfBags [Bag a] -- The list is non-empty
emptyBag = EmptyBag
unitBag = UnitBag
-#if ! defined(COMPILING_GHC)
--- not used in GHC
elemBag :: Eq a => a -> Bag a -> Bool
+
elemBag x EmptyBag = False
elemBag x (UnitBag y) = x==y
elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
+elemBag x (ListBag ys) = any (x ==) ys
elemBag x (ListOfBags bs) = any (x `elemBag`) bs
-#endif
unionManyBags [] = EmptyBag
unionManyBags xs = ListOfBags xs
-- This one is a bit stricter! The bag will get completely evaluated.
-
unionBags EmptyBag b = b
unionBags b EmptyBag = b
unionBags b1 b2 = TwoBags b1 b2
+consBag :: a -> Bag a -> Bag a
+consBag elt bag = (unitBag elt) `unionBags` bag
snocBag :: Bag a -> a -> Bag a
snocBag bag elt = bag `unionBags` (unitBag elt)
isEmptyBag EmptyBag = True
+isEmptyBag (UnitBag x) = False
isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe
+isEmptyBag (ListBag xs) = null xs -- Paranoid, but safe
isEmptyBag (ListOfBags bs) = all isEmptyBag bs
-isEmptyBag other = False
filterBag :: (a -> Bool) -> Bag a -> Bag a
filterBag pred EmptyBag = EmptyBag
where
sat1 = filterBag pred b1
sat2 = filterBag pred b2
+filterBag pred (ListBag vs) = listToBag (filter pred vs)
filterBag pred (ListOfBags bs) = ListOfBags sats
- where
+ where
sats = [filterBag pred b | b <- bs]
+concatBag :: Bag (Bag a) -> Bag a
+
+concatBag EmptyBag = EmptyBag
+concatBag (UnitBag b) = b
+concatBag (TwoBags b1 b2) = concatBag b1 `TwoBags` concatBag b2
+concatBag (ListBag bs) = ListOfBags bs
+concatBag (ListOfBags bbs) = ListOfBags (map concatBag bbs)
-partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
+partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
Bag a {- Don't -})
partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
where
(sat1,fail1) = partitionBag pred b1
(sat2,fail2) = partitionBag pred b2
+partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails)
+ where
+ (sats,fails) = partition pred vs
partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
where
(sats, fails) = unzip [partitionBag pred b | b <- bs]
+foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative
+ -> (a -> r) -- Replace UnitBag with this
+ -> r -- Replace EmptyBag with this
+ -> Bag a
+ -> r
+
+{- Standard definition
+foldBag t u e EmptyBag = e
+foldBag t u e (UnitBag x) = u x
+foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2)
+foldBag t u e (ListBag xs) = foldr (t.u) e xs
+foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs
+-}
+
+-- More tail-recursive definition, exploiting associativity of "t"
+foldBag t u e EmptyBag = e
+foldBag t u e (UnitBag x) = u x `t` e
+foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1
+foldBag t u e (ListBag xs) = foldr (t.u) e xs
+foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs
+
+
+mapBag :: (a -> b) -> Bag a -> Bag b
+mapBag f EmptyBag = EmptyBag
+mapBag f (UnitBag x) = UnitBag (f x)
+mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
+mapBag f (ListBag xs) = ListBag (map f xs)
+mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs)
+
+
listToBag :: [a] -> Bag a
-listToBag lst = foldr TwoBags EmptyBag (map UnitBag lst)
+listToBag [] = EmptyBag
+listToBag vs = ListBag vs
bagToList :: Bag a -> [a]
-bagToList b = b_to_l b []
- where
- -- (b_to_l b xs) flattens b and puts xs on the end.
- b_to_l EmptyBag xs = xs
- b_to_l (UnitBag x) xs = x:xs
- b_to_l (TwoBags b1 b2) xs = b_to_l b1 (b_to_l b2 xs)
- b_to_l (ListOfBags bs) xs = foldr b_to_l xs bs
+bagToList EmptyBag = []
+bagToList (ListBag vs) = vs
+bagToList b = bagToList_append b []
+
+ -- (bagToList_append b xs) flattens b and puts xs on the end.
+bagToList_append EmptyBag xs = xs
+bagToList_append (UnitBag x) xs = x:xs
+bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
+bagToList_append (ListBag xx) xs = xx++xs
+bagToList_append (ListOfBags bs) xs = foldr bagToList_append xs bs
\end{code}
\begin{code}
-#if defined(COMPILING_GHC)
+#ifdef COMPILING_GHC
instance (Outputable a) => Outputable (Bag a) where
ppr sty EmptyBag = ppStr "emptyBag"
ppr sty (UnitBag a) = ppr sty a
ppr sty (TwoBags b1 b2) = ppCat [ppr sty b1, pp'SP, ppr sty b2]
+ ppr sty (ListBag as) = interpp'SP sty as
ppr sty (ListOfBags bs) = ppCat [ppLbrack, interpp'SP sty bs, ppRbrack]
#endif {- COMPILING_GHC -}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface BitSet where
-data BitSet
-emptyBS :: BitSet
-listBS :: BitSet -> [Int]
-minusBS :: BitSet -> BitSet -> BitSet
-mkBS :: [Int] -> BitSet
-singletonBS :: Int -> BitSet
-unionBS :: BitSet -> BitSet -> BitSet
-
#elif defined(__YALE_HASKELL__)
{-hide import from mkdependHS-}
import
- LogOpPrims
+ LogOpPrims
#else
{-hide import from mkdependHS-}
import
data BitSet = MkBS Word#
-emptyBS :: BitSet
+emptyBS :: BitSet
emptyBS = MkBS (int2Word# 0#)
mkBS :: [Int] -> BitSet
#if ! defined(COMPILING_GHC)
-- not used in GHC
isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s#) =
+isEmptyBS (MkBS s#) =
case word2Int# s# of
0# -> True
_ -> False
listBS :: BitSet -> [Int]
listBS s = listify s 0
- where listify (MkBS s#) n =
+ where listify (MkBS s#) n =
case word2Int# s# of
0# -> []
_ -> let s' = (MkBS (s# `shiftr` 1#))
in case word2Int# (s# `and#` (int2Word# 1#)) of
0# -> more
_ -> n : more
-# if __GLASGOW_HASKELL__ >= 23
shiftr x y = shiftRL# x y
-# else
- shiftr x y = shiftR# x y
-# endif
#elif defined(__YALE_HASKELL__)
data BitSet = MkBS Int
-emptyBS :: BitSet
+emptyBS :: BitSet
emptyBS = MkBS 0
mkBS :: [Int] -> BitSet
#if ! defined(COMPILING_GHC)
-- not used in GHC
isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) =
+isEmptyBS (MkBS s) =
case s of
0 -> True
_ -> False
intersectBS (MkBS x) (MkBS y) = MkBS (x `logandInt` y)
elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) =
+elementBS x (MkBS s) =
case logbitpInt x s of
0 -> False
_ -> True
minusBS :: BitSet -> BitSet -> BitSet
minusBS (MkBS x) (MkBS y) = MkBS (x `logandc2Int` y)
--- rewritten to avoid right shifts (which would give nonsense on negative
+-- rewritten to avoid right shifts (which would give nonsense on negative
-- values.
listBS :: BitSet -> [Int]
listBS (MkBS s) = listify s 0 1
- where listify s n m =
+ where listify s n m =
case s of
0 -> []
_ -> let n' = n+1; m' = m+m in
- case logbitpInt s m of
+ case logbitpInt s m of
0 -> listify s n' m'
_ -> n : listify (s `logandc2Int` m) n' m'
-#else /* HBC, perhaps? */
+#else /* HBC, perhaps? */
data BitSet = MkBS Word
-emptyBS :: BitSet
+emptyBS :: BitSet
emptyBS = MkBS 0
mkBS :: [Int] -> BitSet
#if ! defined(COMPILING_GHC)
-- not used in GHC
isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) =
+isEmptyBS (MkBS s) =
case s of
0 -> True
_ -> False
intersectBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` y)
elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) =
+elementBS x (MkBS s) =
case (1 `bitLsh` x) `bitAnd` s of
0 -> False
_ -> True
listBS :: BitSet -> [Int]
listBS (MkBS s) = listify s 0
- where listify s n =
+ where listify s n =
case s of
0 -> []
_ -> let s' = s `bitRsh` 1
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface CharSeq where
-import PreludePS(_PackedString)
-import Stdio(_FILE)
-data CSeq
-cAppend :: CSeq -> CSeq -> CSeq
-cAppendFile :: _FILE -> CSeq -> _State _RealWorld -> ((), _State _RealWorld)
-cCh :: Char -> CSeq
-cIndent :: Int -> CSeq -> CSeq
-cInt :: Int -> CSeq
-cNL :: CSeq
-cNil :: CSeq
-cPStr :: _PackedString -> CSeq
-cShow :: CSeq -> [Char]
-cStr :: [Char] -> CSeq
-
#endif
cShow
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+#if ! defined(COMPILING_GHC)
+ ) where
+#else
, cAppendFile
) where
-#if __GLASGOW_HASKELL__ < 26
-import PreludePrimIO
-#endif
-import PreludeGlaST
+CHK_Ubiq() -- debugging consistency check
-#else
- ) where
+import PreludeGlaST
#endif
\end{code}
cCh :: Char -> CSeq
cInt :: Int -> CSeq
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
-
-# if __GLASGOW_HASKELL__ < 23
-# define _FILE _Addr
-# endif
-
+#if defined(COMPILING_GHC)
cAppendFile :: _FILE -> CSeq -> PrimIO ()
#endif
\end{code}
| CStr [Char]
| CCh Char
| CInt Int -- equiv to "CStr (show the_int)"
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
+#if defined(COMPILING_GHC)
| CPStr _PackedString
#endif
\end{code}
cCh = CCh
cInt = CInt
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
+#if defined(COMPILING_GHC)
cPStr = CPStr
#else
cPStr = CStr
cLength seq = length (cShow seq) -- *not* the best way to do this!
#endif
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+#if defined(COMPILING_GHC)
cAppendFile file_star seq
= flattenIO file_star seq
#endif
flatten n _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs
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) && __GLASGOW_HASKELL__ >= 23
+#if defined(COMPILING_GHC)
flatten n _FALSE_ (CPStr s) seqs = _unpackPS 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) && __GLASGOW_HASKELL__ >= 23
+#if defined(COMPILING_GHC)
flatten n _TRUE_ (CPStr s) seqs = mkIndent n (_unpackPS s ++ flattenS _FALSE_ seqs)
#endif
\end{code}
It {\em ignores} indentation.
\begin{code}
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+#if defined(COMPILING_GHC)
flattenIO :: _FILE -- file we are writing to
-> CSeq -- Seq to print
-> PrimIO ()
flattenIO file sq
-# if __GLASGOW_HASKELL__ >= 23
| file == ``NULL'' = error "panic:flattenIO" -- really just to force eval :-)
| otherwise
-# endif
= flat sq
where
- flat CNil = BSCC("flatCNil") returnPrimIO () ESCC
-
- flat (CIndent n2 seq) = BSCC("flatCIndent") flat seq ESCC
-
- flat (CAppend seq1 seq2)
- = BSCC("flatCAppend")
- flat seq1 `seqPrimIO` flat seq2
- ESCC
-
- flat CNewline = BSCC("flatCNL") _ccall_ stg_putc '\n' file ESCC
-
- flat (CCh c) = BSCC("flatCCh") _ccall_ stg_putc c file ESCC
-
- flat (CInt i) = BSCC("flatCInt") _ccall_ fprintf file percent_d i ESCC
-
- flat (CStr s) = BSCC("flatCStr") put_str s ESCC
-
-# if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
- flat (CPStr s) = BSCC("flatCPStr") put_pstr s ESCC
-# endif
+ flat CNil = returnPrimIO ()
+ 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_str2 ``stderr'' (str ++ "\n") `seqPrimIO`
put_str2 str
- put_str2 [] = BSCC("putNil") returnPrimIO () ESCC
+ put_str2 [] = returnPrimIO ()
put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _) : cs)
- = BSCC("put4")
- _ccall_ stg_putc c1 file `seqPrimIO`
+ = _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)
- ESCC
put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : cs)
- = BSCC("put3")
- _ccall_ stg_putc c1 file `seqPrimIO`
+ = _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)
- ESCC
put_str2 (c1@(C# _) : c2@(C# _) : cs)
- = BSCC("put2")
- _ccall_ stg_putc c1 file `seqPrimIO`
+ = _ccall_ stg_putc c1 file `seqPrimIO`
_ccall_ stg_putc c2 file `seqPrimIO`
put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
- ESCC
put_str2 (c1@(C# _) : cs)
- = BSCC("put1")
- _ccall_ stg_putc c1 file `seqPrimIO`
+ = _ccall_ stg_putc c1 file `seqPrimIO`
put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
- ESCC
-# if __GLASGOW_HASKELL__ >= 23
put_pstr ps = _putPS file ps
-# endif
-# if __GLASGOW_HASKELL__ >= 23
percent_d = _psToByteArray SLIT("%d")
-# else
-percent_d = "%d"
-# endif
-#endif {- __GLASGOW_HASKELL__ >= 22 -}
+#endif {- COMPILING_GHC -}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Digraph where
-import Maybes(MaybeErr)
-data MaybeErr a b
-dfs :: (a -> a -> Bool) -> (a -> [a]) -> ([a], [a]) -> [a] -> ([a], [a])
-stronglyConnComp :: (a -> a -> Bool) -> [(a, a)] -> [a] -> [[a]]
-topologicalSort :: (a -> a -> Bool) -> [(a, a)] -> [a] -> MaybeErr [a] [[a]]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Digraph]{An implementation of directed graphs}
\begin{code}
+#include "HsVersions.h"
+
module Digraph (
stronglyConnComp,
---OLD: whichCycle, -- MOVED: isCyclic,
topologicalSort,
- dfs, -- deforester
- MaybeErr
+ dfs,
+ MaybeErr,
+
+ -- alternative interface
+ findSCCs, SCC(..), Bag
) where
-import Maybes ( MaybeErr(..) )
+CHK_Ubiq() -- debugging consistency check
+
+import Maybes ( Maybe, MaybeErr(..), maybeToBool )
+import Bag ( Bag, filterBag, bagToList, listToBag )
+import FiniteMap ( FiniteMap, listToFM, lookupFM, lookupWithDefaultFM )
import Util
\end{code}
stronglyConnComp eq edges vertices
= snd (span_tree (new_range reversed_edges)
([],[])
- ( snd (dfs (new_range edges) ([],[]) vertices) )
+ ( snd (dfs (new_range edges) ([],[]) vertices) )
)
where
reversed_edges = map swap edges
- swap (x,y) = (y, x)
+ swap (x,y) = (y,x)
-- new_range :: Eq v => [Edge v] -> v -> [v]
elem x (y:ys) = x `eq` y || x `elem` ys
{- span_tree :: Eq v => (v -> [v])
- -> ([v], [[v]])
- -> [v]
- -> ([v], [[v]])
+ -> ([v], [[v]])
+ -> [v]
+ -> ([v], [[v]])
-}
span_tree r (vs,ns) [] = (vs,ns)
span_tree r (vs,ns) (x:xs)
| x `elem` vs = span_tree r (vs,ns) xs
| True = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') ->
span_tree r (vs',(x:ns'):ns) xs }
-
+
{- dfs :: Eq v => (v -> [v])
- -> ([v], [v])
- -> [v]
- -> ([v], [v])
+ -> ([v], [v])
+ -> [v]
+ -> ([v], [v])
-}
dfs r (vs,ns) [] = (vs,ns)
dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs
-> ([v], [v])
dfs eq r (vs,ns) [] = (vs,ns)
-dfs eq r (vs,ns) (x:xs)
+dfs eq r (vs,ns) (x:xs)
| any (eq x) vs = dfs eq r (vs,ns) xs
- | True = case (dfs eq r (x:vs,[]) (r x)) of
+ | True = case (dfs eq r (x:vs,[]) (r x)) of
(vs',ns') -> dfs eq r (vs',(x:ns')++ns) xs
-
\end{code}
-
-
-@isCyclic@ expects to be applied to an element of the result of a
-stronglyConnComp; it tells whether such an element is a cycle. The
-answer is True if it is not a singleton, of course, but if it is a
-singleton we have to look up in the edges to see if it refers to
-itself.
\begin{code}
-{- MOVED TO POINT OF SINGLE USE: RenameBinds4 (WDP 95/02)
+findSCCs :: Ord key
+ => (vertex -> (key, Bag key)) -- Give key of vertex, and keys of thing's
+ -- immediate neighbours. It's ok for the
+ -- list to contain keys which don't correspond
+ -- to any vertex; they are ignored.
+ -> Bag vertex -- Stuff to be SCC'd
+ -> [SCC vertex] -- The union of all these is the original bag
-isCyclic :: Eq vertex => [Edge vertex] -> [vertex] -> Bool
+data SCC thing = AcyclicSCC thing
+ | CyclicSCC (Bag thing)
-isCyclic edges [] = panic "isCyclic: empty component"
-isCyclic edges [v] = (v,v) `is_elem` edges where { is_elem = isIn "isCyclic" }
-isCyclic edges vs = True
--}
-\end{code}
+findSCCs v_info vs
+ = let
+ (keys, keys_of, edgess) = unzip3 (map do_vertex (bagToList vs))
+ key_map = listToFM keys_of
+ edges = concat edgess
-OLD: The following @whichCycle@ should be called only when the given
-@vertex@ is known to be in one of the cycles. This isn't difficult to
-achieve if the call follows the creation of the list of components by
-@cycles@ (NB: strictness analyser) with all vertices of interest in
-them.
+ do_vertex v = (k, (k, (v, ok_ns)), ok_edges)
+ where
+ (k, ns) = v_info v
+ ok_ns = filter key_in_graph (bagToList ns)
+ ok_edges = map (\n->(k,n)) ok_ns
->{- UNUSED:
->whichCycle :: Eq vertex => [Cycle vertex] -> vertex -> (Cycle vertex)
->whichCycle vss v = head [vs | vs <-vss, v `is_elem` vs] where { is_elem = isIn "whichCycle" }
->-}
+ key_in_graph n = maybeToBool (lookupFM key_map n)
+
+ the_sccs = stronglyConnComp (==) edges keys
+
+ cnv_sccs = map cnv_scc the_sccs
+
+ cnv_scc [] = panic "findSCCs: empty component"
+ cnv_scc [k] | singlecycle k
+ = AcyclicSCC (get_vertex k)
+ cnv_scc ks = CyclicSCC (listToBag (map get_vertex ks))
+
+ singlecycle k = not (isIn "cycle" k (get_neighs k))
+
+ get_vertex k = fst (lookupWithDefaultFM key_map vpanic k)
+ get_neighs k = snd (lookupWithDefaultFM key_map vpanic k)
+
+ vpanic = panic "Digraph: vertix not found from key"
+ in
+ cnv_sccs
+\end{code}
%************************************************************************
%* *
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface FiniteMap where
-import Maybes(Labda)
-import Outputable(Outputable)
-data FiniteMap a b
-type FiniteSet a = FiniteMap a ()
-data Labda a
-addListToFM :: Ord a => FiniteMap a b -> [(a, b)] -> FiniteMap a b
-addListToFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> [(a, b)] -> FiniteMap a b
-addToFM :: Ord a => FiniteMap a b -> a -> b -> FiniteMap a b
-delListFromFM :: Ord a => FiniteMap a b -> [a] -> FiniteMap a b
-elemFM :: Ord a => a -> FiniteMap a b -> Bool
-elementOf :: Ord a => a -> FiniteMap a () -> Bool
-eltsFM :: FiniteMap a b -> [b]
-emptyFM :: FiniteMap a b
-emptySet :: FiniteMap a ()
-fmToList :: FiniteMap a b -> [(a, b)]
-isEmptyFM :: FiniteMap a b -> Bool
-isEmptySet :: FiniteMap a () -> Bool
-keysFM :: FiniteMap b a -> [b]
-listToFM :: Ord a => [(a, b)] -> FiniteMap a b
-lookupFM :: Ord a => FiniteMap a b -> a -> Labda b
-lookupWithDefaultFM :: Ord a => FiniteMap a b -> b -> a -> b
-minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
-minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
-mkSet :: Ord a => [a] -> FiniteMap a ()
-plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
-plusFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> FiniteMap a b -> FiniteMap a b
-setToList :: FiniteMap a () -> [a]
-singletonFM :: a -> b -> FiniteMap a b
-union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
-instance Outputable a => Outputable (FiniteMap a b)
-
%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[FiniteMap]{An implementation of finite maps}
near the end (only \tr{#ifdef COMPILING_GHC}).
\begin{code}
-#if defined(COMPILING_GHC)
+#ifdef COMPILING_GHC
#include "HsVersions.h"
#define IF_NOT_GHC(a) {--}
#else
IF_NOT_GHC(sizeFM COMMA)
isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
-
+
fmToList, keysFM, eltsFM{-used in GHCI-}
-#if defined(COMPILING_GHC)
+#ifdef COMPILING_GHC
, FiniteSet(..), emptySet, mkSet, isEmptySet
, elementOf, setToList, union, minusSet{-exported for GHCI-}
#endif
import Maybes
-#if defined(COMPILING_GHC)
-import AbsUniType
+#ifdef COMPILING_GHC
+import Ubiq{-uitous-}
+# ifdef DEBUG
import Pretty
-import Outputable
-import Util
-import CLabelInfo ( CLabel ) -- for specialising
+# endif
#if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc ( Reg ) -- ditto
#define IF_NCG(a) a
#else
#define IF_NCG(a) {--}
-- Combines with previous binding
addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> key -> elt
+ -> FiniteMap key elt -> key -> elt
-> FiniteMap key elt
addListToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> [(key,elt)]
+ -> FiniteMap key elt -> [(key,elt)]
-> FiniteMap key elt
-- Deletion doesn't complain if you try to delete something
-> FiniteMap key elt
-- Combines bindings for the same thing with the given function
-plusFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
+plusFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
-> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
minusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
-intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+ -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-- MAPPING, FOLDING, FILTERING
foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
-filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)
+filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)
-> FiniteMap key elt -> FiniteMap key elt
-- INTERROGATING
\begin{code}
data FiniteMap key elt
- = EmptyFM
+ = EmptyFM
| Branch key elt -- Key and elt stored here
IF_GHC(Int#,Int{-STRICT-}) -- Size >= 1
(FiniteMap key elt) -- Children
_GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
_LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
_EQ -> glueBal fm_l fm_r
-#else
+#else
| del_key > key
= mkBalBranch key elt fm_l (delFromFM fm_r del_key)
plusFM_C combiner EmptyFM fm2 = fm2
plusFM_C combiner fm1 EmptyFM = fm1
plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
- = mkVBalBranch split_key new_elt
+ = mkVBalBranch split_key new_elt
(plusFM_C combiner lts left)
(plusFM_C combiner gts right)
where
| maybeToBool maybe_elt1 -- split_elt *is* in intersection
= mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)
- (intersectFM_C combiner gts right)
+ (intersectFM_C combiner gts right)
| otherwise -- split_elt is *not* in intersection
= glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)
= foldFM k (k key elt (foldFM k z fm_r)) fm_l
mapFM f EmptyFM = emptyFM
-mapFM f (Branch key elt size fm_l fm_r)
+mapFM f (Branch key elt size fm_l fm_r)
= Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)
filterFM p EmptyFM = emptyFM
= case _tagCmp key_to_find key of
_LT -> lookupFM fm_l key_to_find
_GT -> lookupFM fm_r key_to_find
- _EQ -> Just elt
+ _EQ -> Just elt
#else
| key_to_find < key = lookupFM fm_l key_to_find
| key_to_find > key = lookupFM fm_r key_to_find
mkBranch :: (Ord key OUTPUTABLE_key) -- Used for the assertion checking only
=> Int
- -> key -> elt
+ -> key -> elt
-> FiniteMap key elt -> FiniteMap key elt
-> FiniteMap key elt
\begin{code}
mkBalBranch :: (Ord key OUTPUTABLE_key)
- => key -> elt
+ => key -> elt
-> FiniteMap key elt -> FiniteMap key elt
-> FiniteMap key elt
mkBalBranch key elt fm_L fm_R
- | size_l + size_r < 2
+ | size_l + size_r < 2
= mkBranch 1{-which-} key elt fm_L fm_R
| size_r > sIZE_RATIO * size_l -- Right tree too big
= case fm_R of
- Branch _ _ _ fm_rl fm_rr
+ Branch _ _ _ fm_rl fm_rr
| sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
| otherwise -> double_L fm_L fm_R
-- Other case impossible
| size_l > sIZE_RATIO * size_r -- Left tree too big
= case fm_L of
- Branch _ _ _ fm_ll fm_lr
+ Branch _ _ _ fm_ll fm_lr
| sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
| otherwise -> double_R fm_L fm_R
-- Other case impossible
| otherwise -- No imbalance
= mkBranch 2{-which-} key elt fm_L fm_R
-
+
where
size_l = sizeFM fm_L
size_r = sizeFM fm_R
- single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
+ single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
= mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
- = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll)
+ = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll)
(mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
\begin{code}
mkVBalBranch :: (Ord key OUTPUTABLE_key)
- => key -> elt
+ => key -> elt
-> FiniteMap key elt -> FiniteMap key elt
-> FiniteMap key elt
| otherwise
= mkBranch 13{-which-} key elt fm_l fm_r
- where
+ where
size_l = sizeFM fm_l
size_r = sizeFM fm_r
\end{code}
glueBal EmptyFM fm2 = fm2
glueBal fm1 EmptyFM = fm1
-glueBal fm1 fm2
+glueBal fm1 fm2
-- The case analysis here (absent in Adams' program) is really to deal
-- with the case where fm2 is a singleton. Then deleting the minimum means
-- we pass an empty tree to mkBalBranch, which breaks its invariant.
| sizeFM fm2 > sizeFM fm1
= mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
-
+
| otherwise
= mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
where
glueVBal EmptyFM fm2 = fm2
glueVBal fm1 EmptyFM = fm1
glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
- fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
+ fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
| sIZE_RATIO * size_l < size_r
= mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
-- splitLT fm split_key = fm restricted to keys < split_key
--- splitGE fm split_key = fm restricted to keys >= split_key (UNUSED)
-- splitGT fm split_key = fm restricted to keys > split_key
splitLT EmptyFM split_key = emptyFM
| otherwise = fm_l
#endif
-{- UNUSED:
-splitGE EmptyFM split_key = emptyFM
-splitGE (Branch key elt _ fm_l fm_r) split_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _GT -> splitGE fm_r split_key
- _LT -> mkVBalBranch key elt (splitGE fm_l split_key) fm_r
- _EQ -> mkVBalBranch key elt emptyFM fm_r
-#else
- | split_key > key = splitGE fm_r split_key
- | split_key < key = mkVBalBranch key elt (splitGE fm_l split_key) fm_r
- | otherwise = mkVBalBranch key elt emptyFM fm_r
-#endif
--}
-
splitGT EmptyFM split_key = emptyFM
splitGT (Branch key elt _ fm_l fm_r) split_key
#ifdef __GLASGOW_HASKELL__
%************************************************************************
\begin{code}
-#if defined(COMPILING_GHC)
-
-{- this is the real one actually...
-instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where
- ppr sty fm = ppr sty (fmToList fm)
--}
+#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
--- temp debugging (ToDo: rm)
instance (Outputable key) => Outputable (FiniteMap key elt) where
ppr sty fm = pprX sty fm
pprX sty fm_r, ppRparen]
#endif
-#if !defined(COMPILING_GHC)
+#ifndef COMPILING_GHC
instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
fm_1 == fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test
- (fmToList fm_1 == fmToList fm_2)
+ (fmToList fm_1 == fmToList fm_2)
{- NO: not clear what The Right Thing to do is:
instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
fm_1 <= fm_2 = (sizeFM fm_1 <= sizeFM fm_2) && -- quick test
- (fmToList fm_1 <= fmToList fm_2)
+ (fmToList fm_1 <= fmToList fm_2)
-}
#endif
\end{code}
%************************************************************************
\begin{code}
-#if defined(COMPILING_GHC)
+#ifdef COMPILING_GHC
type FiniteSet key = FiniteMap key ()
emptySet :: FiniteSet key
\tr{Uniques}, for dastardly efficiency reasons.
\begin{code}
+#if 0
#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__
- -- the __GLASGOW_HASKELL__ chk avoids an hbc 0.999.7 bug
{-# SPECIALIZE listToFM
:: [(Int,elt)] -> FiniteMap Int elt,
#-}
#endif {- compiling for GHC -}
+#endif {- 0 -}
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface LiftMonad where
-bogusLiftMonadThing :: Bool
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[LiftMonad]{A lifting monad}
-
-\begin{code}
-#if defined(__GLASGOW_HASKELL__)
-module LiftMonad where { bogusLiftMonadThing = True }
-
-#else
-module LiftMonad (
- LiftM, -- abstract
- thenLft, returnLft, mapLft
- ) where
-
-infixr 9 `thenLft`
-
-data LiftM a = MkLiftM a
- -- Just add a bottom element under the domain
-\end{code}
-
-Notice that @thenLft@ is strict in its first argument.
-
-\begin{code}
-thenLft :: LiftM a -> (a -> b) -> b
-(MkLiftM x) `thenLft` cont = cont x
-
-returnLft :: a -> LiftM a
-returnLft a = MkLiftM a
-
-mapLft :: (a -> LiftM b) -> [a] -> LiftM [b]
-mapLft f [] = returnLft []
-mapLft f (x:xs)
- = f x `thenLft` \ x2 ->
- mapLft f xs `thenLft` \ xs2 ->
- returnLft (x2 : xs2)
-
-#endif
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface ListSetOps where
-intersectLists :: Eq a => [a] -> [a] -> [a]
-minusList :: Eq a => [a] -> [a] -> [a]
-unionLists :: Eq a => [a] -> [a] -> [a]
-
#if defined(COMPILING_GHC)
import Util
# ifdef USE_ATTACK_PRAGMAS
-import AbsUniType
+import Type
import Id ( Id )
# endif
#endif
--- /dev/null
+%************************************************************************
+%* *
+\subsection[MatchEnv]{Matching environments}
+%* *
+%************************************************************************
+
+\begin{code}
+#include "HsVersions.h"
+
+module MatchEnv (
+ MatchEnv, nullMEnv, mkMEnv,
+ lookupMEnv, insertMEnv,
+ mEnvToList
+) where
+
+CHK_Ubiq() -- debugging consistency check
+
+import Maybes ( MaybeErr(..), returnMaB, thenMaB, failMaB )
+\end{code}
+
+``Matching'' environments allow you to bind a template to a value;
+when you look up in it, you supply a value which is matched against
+the template.
+
+\begin{code}
+data MatchEnv key value
+ = EmptyME -- Common, so special-cased
+ | ME [(key, value)]
+\end{code}
+
+For now we just use association lists. The list is maintained sorted
+in order of {\em decreasing specificness} of @key@, so that the first
+match will be the most specific.
+
+\begin{code}
+nullMEnv :: MatchEnv a b
+nullMEnv = EmptyME
+
+mkMEnv :: [(key, value)] -> MatchEnv key value
+mkMEnv stuff = ME stuff
+
+mEnvToList :: MatchEnv key value -> [(key, value)]
+mEnvToList EmptyME = []
+mEnvToList (ME stuff) = stuff
+\end{code}
+
+@lookupMEnv@ looks up in a @MatchEnv@. It simply takes the first
+match, which should be the most specific.
+
+\begin{code}
+lookupMEnv :: (key1 {- template -} -> -- Matching function
+ key2 {- instance -} ->
+ Maybe match_info)
+ -> MatchEnv key1 value -- The envt
+ -> key2 -- Key
+ -> Maybe (value, -- Value
+ match_info) -- Match info returned by matching fn
+
+
+lookupMEnv key_match EmptyME key = Nothing
+lookupMEnv key_match (ME alist) key
+ = find alist
+ where
+ find [] = Nothing
+ find ((tpl, val) : rest)
+ = case (key_match tpl key) of
+ Nothing -> find rest
+ Just match_info -> Just (val,match_info)
+\end{code}
+
+@insertMEnv@ extends a match environment, checking for overlaps.
+
+\begin{code}
+insertMEnv :: (key {- template -} -> -- Matching function
+ key {- instance -} ->
+ Maybe match_info)
+ -> MatchEnv key value -- Envt
+ -> key -> value -- New item
+ -> MaybeErr (MatchEnv key value) -- Success...
+ (key, value) -- Failure: Offending overlap
+
+insertMEnv match_fn EmptyME key value = returnMaB (ME [(key, value)])
+insertMEnv match_fn (ME alist) key value
+ = insert alist
+ where
+ -- insertMEnv has to put the new item in BEFORE any keys which are
+ -- LESS SPECIFIC than the new key, and AFTER any keys which are
+ -- MORE SPECIFIC The list is maintained in specific-ness order, so
+ -- we just stick it in either last, or just before the first key
+ -- of which the new key is an instance. We check for overlap at
+ -- that point.
+
+ insert [] = returnMaB (ME [(key, value)])
+ insert ((t,v) : rest)
+ = case (match_fn t key) of
+ Nothing ->
+ -- New key is not an instance of this existing one, so
+ -- continue down the list.
+ insert rest `thenMaB` \ (ME rest') ->
+ returnMaB (ME((t,v):rest'))
+
+ Just match_info ->
+ -- New key *is* an instance of the old one, so check the
+ -- other way round in case of identity.
+
+ case (match_fn key t) of
+ Just _ -> failMaB (t,v)
+ -- Oops; overlap
+
+ Nothing -> returnMaB (ME ((key,value):(t,v):rest))
+ -- All ok; insert here
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Maybes where
-data Labda a = Hamna | Ni a
-data MaybeErr a b = Succeeded a | Failed b
-allMaybes :: [Labda a] -> Labda [a]
-assocMaybe :: Eq a => [(a, b)] -> a -> Labda b
-catMaybes :: [Labda a] -> [a]
-failMaB :: b -> MaybeErr a b
-failMaybe :: Labda a
-firstJust :: [Labda a] -> Labda a
-mapMaybe :: (a -> Labda b) -> [a] -> Labda [b]
-maybeToBool :: Labda a -> Bool
-mkLookupFun :: (a -> a -> Bool) -> [(a, b)] -> a -> Labda b
-returnMaB :: a -> MaybeErr a b
-returnMaybe :: a -> Labda a
-thenMaB :: MaybeErr a c -> (a -> MaybeErr b c) -> MaybeErr b c
-thenMaybe :: Labda a -> (a -> Labda b) -> Labda b
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Maybes]{The `Maybe' types and associated utility functions}
#endif
module Maybes (
- Maybe(..), MaybeErr(..),
+-- Maybe(..), -- no, it's in 1.3
+ MaybeErr(..),
allMaybes, -- GHCI only
- assocMaybe,
catMaybes,
+ firstJust,
+ expectJust,
+ maybeToBool,
+
+ assocMaybe,
+ mkLookupFun, mkLookupFunDef,
+
failMaB,
failMaybe,
- firstJust,
+ seqMaybe,
mapMaybe, -- GHCI only
- maybeToBool,
- mkLookupFun,
returnMaB,
returnMaybe, -- GHCI only
thenMaB,
) where
#if defined(COMPILING_GHC)
-import AbsUniType
-import Id
-import IdInfo
-import Name
-import Outputable
+
+CHK_Ubiq() -- debugging consistency check
+
#if USE_ATTACK_PRAGMAS
import Util
#endif
maybeToBool (Just x) = True
\end{code}
-@catMaybes@ takes a list of @Maybe@s and returns a list of
+@catMaybes@ takes a list of @Maybe@s and returns a list of
the contents of all the @Just@s in it. @allMaybes@ collects
a list of @Justs@ into a single @Just@, returning @Nothing@ if there
are any @Nothings@.
b -> b
\end{code}
+\begin{code}
+expectJust :: String -> Maybe a -> a
+{-# INLINE expectJust #-}
+expectJust err (Just x) = x
+expectJust err Nothing = error ("expectJust " ++ err)
+\end{code}
+
+The Maybe monad
+~~~~~~~~~~~~~~~
+\begin{code}
+#if __HASKELL1__ < 3
+thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b
+m `thenMaybe` k = case m of
+ Nothing -> Nothing
+ Just a -> k a
+#endif
+
+seqMaybe :: Maybe a -> Maybe a -> Maybe a
+seqMaybe (Just x) _ = Just x
+seqMaybe Nothing my = my
+
+returnMaybe :: a -> Maybe a
+returnMaybe = Just
+
+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
+~~~~~~~~~~~~~~~~
+
@assocMaybe@ looks up in an assocation list, returning
@Nothing@ if it fails.
lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
#if defined(COMPILING_GHC)
-{-# SPECIALIZE assocMaybe
+{-? SPECIALIZE assocMaybe
:: [(String, b)] -> String -> Maybe b,
[(Id, b)] -> Id -> Maybe b,
[(Class, b)] -> Class -> Maybe b,
#endif
\end{code}
-@mkLookupFun alist s@ is a function which looks up
-@s@ in the association list @alist@, returning a Maybe type.
+@mkLookupFun eq alist@ is a function which looks up
+its argument in the association list @alist@, returning a Maybe type.
+@mkLookupFunDef@ is similar except that it is given a value to return
+on failure.
\begin{code}
mkLookupFun :: (key -> key -> Bool) -- Equality predicate
= case [a | (s',a) <- alist, s' `eq` s] of
[] -> Nothing
(a:_) -> Just a
-\end{code}
-\begin{code}
-#if __HASKELL1__ < 3
-thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b
-m `thenMaybe` k = case m of
- Nothing -> Nothing
- Just a -> k a
-#endif
-returnMaybe :: a -> Maybe a
-returnMaybe = Just
+mkLookupFunDef :: (key -> key -> Bool) -- Equality predicate
+ -> [(key,val)] -- The assoc list
+ -> val -- Value to return on failure
+ -> key -- The key
+ -> val -- The corresponding value
-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') ))
+mkLookupFunDef eq alist deflt s
+ = case [a | (s',a) <- alist, s' `eq` s] of
+ [] -> deflt
+ (a:_) -> a
\end{code}
%************************************************************************
\begin{code}
listMaybeErrs :: [MaybeErr val err] -> MaybeErr [val] [err]
listMaybeErrs
- = foldr combine (Succeeded [])
+ = foldr combine (Succeeded [])
where
combine (Succeeded v) (Succeeded vs) = Succeeded (v:vs)
combine (Failed err) (Succeeded _) = Failed [err]
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1993-1996
+%
+
+This is useful, general stuff for the Native Code Generator.
+
+\begin{code}
+module OrdList (
+ OrdList,
+
+ mkParList, mkSeqList, mkEmptyList, mkUnitList,
+
+ flattenOrdList
+ ) where
+
+import Util ( mapAccumB, mapAccumL, mapAccumR )
+\end{code}
+
+This section provides an ordering list that allows fine grain
+parallelism to be expressed. This is used (ultimately) for scheduling
+of assembly language instructions.
+
+\begin{code}
+data OrdList a
+ = SeqList (OrdList a) (OrdList a)
+ | ParList (OrdList a) (OrdList a)
+ | OrdObj a
+ | NoObj
+ deriving ()
+
+mkSeqList a b = SeqList a b
+mkParList a b = ParList a b
+mkEmptyList = NoObj
+mkUnitList = OrdObj
+\end{code}
+
+%------------------------------------------------------------------------
+
+Notice this this throws away all potential expression of parallelism.
+
+\begin{code}
+flattenOrdList :: OrdList a -> [a]
+
+flattenOrdList ol
+ = flat ol []
+ where
+ flat NoObj rest = rest
+ flat (OrdObj x) rest = x:rest
+ flat (ParList a b) rest = flat a (flat b rest)
+ flat (SeqList a b) rest = flat a (flat b rest)
+
+{- DEBUGGING ONLY:
+instance Text (OrdList a) where
+ showsPrec _ NoObj = showString "_N_"
+ showsPrec _ (OrdObj _) = showString "_O_"
+ showsPrec _ (ParList a b) = showString "(PAR " . shows a . showChar ')'
+ showsPrec _ (SeqList a b) = showString "(SEQ " . shows a . showChar ')'
+-}
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Outputable where
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle(..), Pretty(..), PrettyRep)
-import SrcLoc(SrcLoc)
-import UniType(UniType)
-import Unique(Unique)
-class NamedThing a where
- getExportFlag :: a -> ExportFlag
- isLocallyDefined :: a -> Bool
- getOrigName :: a -> (_PackedString, _PackedString)
- getOccurrenceName :: a -> _PackedString
- getInformingModules :: a -> [_PackedString]
- getSrcLoc :: a -> SrcLoc
- getTheUnique :: a -> Unique
- hasType :: a -> Bool
- getType :: a -> UniType
- fromPreludeCore :: a -> Bool
-class Outputable a where
- ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
-data ExportFlag = ExportAll | ExportAbs | NotExported
-data GlobalSwitch
-data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char])
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-data SrcLoc
-data UniType
-data Unique
-getLocalName :: NamedThing a => a -> _PackedString
-ifPprDebug :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ifPprInterface :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ifPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ifnotPprForUser :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ifnotPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-interpp'SP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep
-interppSP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep
-isAconop :: _PackedString -> Bool
-isAvarid :: _PackedString -> Bool
-isAvarop :: _PackedString -> Bool
-isConop :: _PackedString -> Bool
-isExported :: NamedThing a => a -> Bool
-isOpLexeme :: NamedThing a => a -> Bool
-ltLexical :: (NamedThing a, NamedThing b) => a -> b -> Bool
-pprNonOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep
-pprOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep
-instance (Outputable a, Outputable b) => Outputable (a, b)
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
-instance Outputable Bool
-instance Outputable a => Outputable [a]
-
%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1996
%
\section[Outputable]{Classes for pretty-printing}
-- PRINTERY AND FORCERY
Outputable(..), -- class
- PprStyle(..), -- style-ry (re-exported)
interppSP, interpp'SP,
---UNUSED: ifPprForUser,
ifnotPprForUser,
- ifPprDebug, --UNUSED: ifnotPprDebug,
+ ifPprDebug,
ifPprShowAll, ifnotPprShowAll,
- ifPprInterface, --UNUSED: ifnotPprInterface,
---UNUSED: ifPprForC, ifnotPprForC,
---UNUSED: ifPprUnfolding, ifnotPprUnfolding,
+ ifPprInterface,
isOpLexeme, pprOp, pprNonOp,
- isConop, isAconop, isAvarid, isAvarop, --UNUSED: isAconid,
+ isConop, isAconop, isAvarid, isAvarop
-- and to make the interface self-sufficient...
- Pretty(..), GlobalSwitch,
- PrettyRep, UniType, Unique, SrcLoc
) where
-import AbsUniType ( UniType,
- TyCon, Class, TyVar, TyVarTemplate -- for SPECIALIZing
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
- )
-import Id ( Id ) -- for specialising
-import NameTypes -- for specialising
-import ProtoName -- for specialising
+import Ubiq{-uitous-}
+
+import PprStyle ( PprStyle(..) )
import Pretty
-import SrcLoc ( SrcLoc )
-import Unique ( Unique )
-import Util
+import Util ( cmpPString )
\end{code}
%************************************************************************
getOccurrenceName :: a -> FAST_STRING
getInformingModules :: a -> [FAST_STRING]
getSrcLoc :: a -> SrcLoc
- getTheUnique :: a -> Unique
- hasType :: a -> Bool
- getType :: a -> UniType
+ getItsUnique :: a -> Unique
fromPreludeCore :: a -> Bool
-- see also friendly functions that follow...
\end{code}
\item[@getSrcLoc@:]
Obvious.
-\item[@hasType@ and @getType@:]
-In pretty-printing @AbsSyntax@, we need to query if a datatype has
-types attached yet or not. We use @hasType@ to see if there are types
-available; and @getType@ if we want to grab one... (Ugly but effective)
-
\item[@fromPreludeCore@:]
Tests a quite-delicate property: it is \tr{True} iff the entity is
actually defined in \tr{PreludeCore} (or \tr{PreludeBuiltin}), or if
{-# SPECIALIZE interpp'SP :: PprStyle -> [ProtoName] -> Pretty #-}
{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-}
{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [UniType] -> Pretty #-}
+{-# SPECIALIZE interpp'SP :: PprStyle -> [Type] -> Pretty #-}
#endif
\end{code}
\begin{code}
---UNUSED: ifPprForUser sty p = case sty of PprForUser -> p ; _ -> ppNil
ifPprDebug sty p = case sty of PprDebug -> p ; _ -> ppNil
ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> ppNil
-ifPprInterface sty p = case sty of PprInterface _ -> p ; _ -> ppNil
---UNUSED: ifPprForC sty p = case sty of PprForC _ -> p ; _ -> ppNil
---UNUSED: ifPprUnfolding sty p = case sty of PprUnfolding _ -> p ; _ -> ppNil
-
-ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p
---UNUSED: ifnotPprDebug sty p = case sty of PprDebug -> ppNil ; _ -> p
-ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
---UNUSED: ifnotPprInterface sty p = case sty of PprInterface _ -> ppNil; _ -> p
---UNUSED: ifnotPprForC sty p = case sty of PprForC _ -> ppNil; _ -> p
---UNUSED: ifnotPprUnfolding sty p = case sty of PprUnfolding _ -> ppNil; _ -> p
+ifPprInterface sty p = case sty of PprInterface -> p ; _ -> ppNil
+
+ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p
+ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
\end{code}
These functions test strings to see if they fit the lexical categories
isConop cs
| _NULL_ cs = False
- | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
- | otherwise = isUpper c || c == ':'
- where
+ | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
+ | otherwise = isUpper c || c == ':'
+ || c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!!
+ || isUpperISO c
+ where
c = _HEAD_ cs
-{- UNUSED:
-isAconid [] = False
-isAconid ('_':cs) = isAconid cs
-isAconid (c:cs) = isUpper c
--}
-
isAconop cs
| _NULL_ cs = False
| otherwise = c == ':'
c = _HEAD_ cs
isAvarid cs
- | _NULL_ cs = False
- | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
- | otherwise = isLower c
+ | _NULL_ cs = False
+ | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
+ | isLower c = True
+ | isLowerISO c = True
+ | otherwise = False
where
c = _HEAD_ cs
isAvarop cs
- | _NULL_ cs = False
- | isLower c = False -- shortcut
- | isUpper c = False -- ditto
- | otherwise = c `elem` "!#$%&*+./<=>?@\\^|~-" -- symbol or minus
+ | _NULL_ cs = False
+ | isLower c = False
+ | isUpper c = False
+ | c `elem` "!#$%&*+./<=>?@\\^|~-" = True
+ | isSymbolISO c = True
+ | otherwise = False
where
c = _HEAD_ cs
+
+isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
+isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
+isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
\end{code}
And one ``higher-level'' interface to those:
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1996
+%
+\section[PprStyle]{Pretty-printing `styles'}
+
+\begin{code}
+#include "HsVersions.h"
+
+module PprStyle (
+ PprStyle(..),
+ codeStyle
+ ) where
+
+CHK_Ubiq() -- debugging consistency check
+
+data PprStyle
+ = PprForUser -- Pretty-print in a way that will
+ -- make sense to the ordinary user;
+ -- must be very close to Haskell
+ -- syntax, etc. ToDo: how diff is
+ -- this from what pprInterface must
+ -- do?
+ | PprDebug -- Standard debugging output
+ | PprShowAll -- Debugging output which leaves
+ -- nothing to the imagination
+ | PprInterface -- Interface generation
+ | PprForC -- must print out C-acceptable names
+ | PprUnfolding -- for non-interface intermodule info
+ -- the compiler writes/reads
+ | PprForAsm -- must print out assembler-acceptable names
+ Bool -- prefix CLabel with underscore?
+ (String -> String) -- format AsmTempLabel
+\end{code}
+
+Orthogonal to the above printing styles are (possibly) some
+command-line flags that affect printing (often carried with the
+style). The most likely ones are variations on how much type info is
+shown.
+
+The following test decides whether or not we are actually generating
+code (either C or assembly).
+\begin{code}
+codeStyle :: PprStyle -> Bool
+
+codeStyle PprForC = True
+codeStyle (PprForAsm _ _) = True
+codeStyle _ = False
+\end{code}
+
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Pretty where
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Stdio(_FILE)
-import Unpretty(Unpretty(..))
-data CSeq
-data Delay a
-data GlobalSwitch
-data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char])
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep = MkPrettyRep CSeq (Delay Int) Bool Bool
-type Unpretty = CSeq
-codeStyle :: PprStyle -> Bool
-pp'SP :: Int -> Bool -> PrettyRep
-ppAbove :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ppAboves :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppAppendFile :: _FILE -> Int -> (Int -> Bool -> PrettyRep) -> _State _RealWorld -> ((), _State _RealWorld)
-ppBeside :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ppBesides :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppCat :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppChar :: Char -> Int -> Bool -> PrettyRep
-ppComma :: Int -> Bool -> PrettyRep
-ppDouble :: Double -> Int -> Bool -> PrettyRep
-ppEquals :: Int -> Bool -> PrettyRep
-ppFloat :: Float -> Int -> Bool -> PrettyRep
-ppHang :: (Int -> Bool -> PrettyRep) -> Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ppInt :: Int -> Int -> Bool -> PrettyRep
-ppInteger :: Integer -> Int -> Bool -> PrettyRep
-ppInterleave :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppIntersperse :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppLbrack :: Int -> Bool -> PrettyRep
-ppLparen :: Int -> Bool -> PrettyRep
-ppNest :: Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
-ppNil :: Int -> Bool -> PrettyRep
-ppPStr :: _PackedString -> Int -> Bool -> PrettyRep
-ppRational :: Ratio Integer -> Int -> Bool -> PrettyRep
-ppRbrack :: Int -> Bool -> PrettyRep
-ppRparen :: Int -> Bool -> PrettyRep
-ppSP :: Int -> Bool -> PrettyRep
-ppSemi :: Int -> Bool -> PrettyRep
-ppSep :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
-ppShow :: Int -> (Int -> Bool -> PrettyRep) -> [Char]
-ppStr :: [Char] -> Int -> Bool -> PrettyRep
-prettyToUn :: (Int -> Bool -> PrettyRep) -> CSeq
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Pretty]{Pretty-printing data type}
Pretty(..),
#if defined(COMPILING_GHC)
- PprStyle(..),
prettyToUn,
- codeStyle, -- UNUSED: stySwitch,
#endif
ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
ppFloat, ppDouble,
-#if __GLASGOW_HASKELL__ >= 23
+#if __GLASGOW_HASKELL__
-- may be able to *replace* ppDouble
ppRational,
#endif
ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
ppSemi, ppComma, ppEquals,
+ ppBracket, ppParens,
ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
- ppShow,
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+ ppShow, speakNth,
+
+#if defined(COMPILING_GHC)
ppAppendFile,
#endif
-- abstract type, to complete the interface...
PrettyRep(..), CSeq, Delay
#if defined(COMPILING_GHC)
- , GlobalSwitch, Unpretty(..)
+ , Unpretty(..)
#endif
) where
-import CharSeq
#if defined(COMPILING_GHC)
+
+CHK_Ubiq() -- debugging consistency check
+
import Unpretty ( Unpretty(..) )
-import CmdLineOpts ( GlobalSwitch )
#endif
+
+import CharSeq
\end{code}
-Based on John Hughes's pretty-printing library. For now, that code
-and notes for it are in files \tr{pp-rjmh*} (ToDo: rm).
+Based on John Hughes's pretty-printing library. Loosely. Very
+loosely.
%************************************************
%* *
ppInteger :: Integer -> Pretty
ppDouble :: Double -> Pretty
ppFloat :: Float -> Pretty
-#if __GLASGOW_HASKELL__ >= 23
ppRational :: Rational -> Pretty
-#endif
+
+ppBracket :: Pretty -> Pretty -- put brackets around it
+ppParens :: Pretty -> Pretty -- put parens around it
ppBeside :: Pretty -> Pretty -> Pretty
ppBesides :: [Pretty] -> Pretty
ppShow :: Int -> Pretty -> [Char]
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
-# if __GLASGOW_HASKELL__ < 23
-# define _FILE _Addr
-# endif
+#if defined(COMPILING_GHC)
ppAppendFile :: _FILE -> Int -> Pretty -> PrimIO ()
#endif
\end{code}
= case (p width False) of
MkPrettyRep seq ll emp sl -> cShow seq
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
+#if defined(COMPILING_GHC)
ppAppendFile f width p
= case (p width False) of
MkPrettyRep seq ll emp sl -> cAppendFile f seq
ppInteger n = ppStr (show n)
ppDouble n = ppStr (show n)
ppFloat n = ppStr (show n)
-#if __GLASGOW_HASKELL__ >= 23
---ppRational n = ppStr (_showRational 30 n)
ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n)
-#endif
ppSP = ppChar ' '
pp'SP = ppStr ", "
ppComma = ppChar ','
ppEquals = ppChar '='
+ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack)
+ppParens p = ppBeside ppLparen (ppBeside p ppRparen)
+
ppInterleave sep ps = ppSep (pi ps)
where
pi [] = []
MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
if emp1 then
p2 width is_vert
- else
+ else
if (ll1 <= n) || sl2 then -- very ppBesideSP'ish
-- Hang it if p1 shorter than indent or if it doesn't fit
MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2)))
ppAboves ps width is_vert -- Takes several lines
\end{code}
+
+@speakNth@ converts an integer to a verbal index; eg 1 maps to
+``first'' etc.
+
+\begin{code}
+speakNth :: Int -> Pretty
+
+speakNth 1 = ppStr "first"
+speakNth 2 = ppStr "second"
+speakNth 3 = ppStr "third"
+speakNth 4 = ppStr "fourth"
+speakNth 5 = ppStr "fifth"
+speakNth 6 = ppStr "sixth"
+speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ]
+ where
+ st_nd_rd_th | n_rem_10 == 1 = "st"
+ | n_rem_10 == 2 = "nd"
+ | n_rem_10 == 3 = "rd"
+ | otherwise = "th"
+
+ n_rem_10 = n `rem` 10
+\end{code}
+
+
%************************************************************************
%* *
\subsection[Outputable-print]{Pretty-printing stuff}
%* *
%************************************************************************
-ToDo: this is here for no-original-name reasons (mv?).
-
-There is no clearly definitive list of @PprStyles@; I suggest the
-following:
-
\begin{code}
#if defined(COMPILING_GHC)
-- to the end of file
-data PprStyle
- = PprForUser -- Pretty-print in a way that will
- -- make sense to the ordinary user;
- -- must be very close to Haskell
- -- syntax, etc. ToDo: how diff is
- -- this from what pprInterface must
- -- do?
- | PprDebug -- Standard debugging output
- | PprShowAll -- Debugging output which leaves
- -- nothing to the imagination
- | PprInterface -- Interface generation
- (GlobalSwitch -> Bool) -- (we can look at cmd-line flags)
- | PprForC -- must print out C-acceptable names
- (GlobalSwitch -> Bool) -- (ditto)
- | PprUnfolding -- for non-interface intermodule info
- (GlobalSwitch -> Bool) -- the compiler writes/reads
- | PprForAsm -- must print out assembler-acceptable names
- (GlobalSwitch -> Bool) -- (ditto)
- Bool -- prefix CLabel with underscore?
- (String -> String) -- format AsmTempLabel
-\end{code}
-
-The following test decides whether or not we are actually generating
-code (either C or assembly).
-\begin{code}
-codeStyle :: PprStyle -> Bool
-codeStyle (PprForC _) = True
-codeStyle (PprForAsm _ _ _) = True
-codeStyle _ = False
-
-{- UNUSED:
-stySwitch :: PprStyle -> GlobalSwitch -> Bool
-stySwitch (PprInterface sw) = sw
-stySwitch (PprForC sw) = sw
-stySwitch (PprForAsm sw _ _) = sw
--}
-\end{code}
-
-Orthogonal to these printing styles are (possibly) some command-line
-flags that affect printing (often carried with the style). The most
-likely ones are variations on how much type info is shown.
-
-\begin{code}
prettyToUn :: Pretty -> Unpretty
prettyToUn p
fromRationalX :: (RealFloat a) => Rational -> a
fromRationalX r =
- let
+ let
h = ceiling (huge `asTypeOf` x)
b = toInteger (floatRadix x)
x = fromRat 0 r
fromRat e0 r' =
let d = denominator r'
n = numerator r'
- in if d > h then
+ in if d > h then
let e = integerLogBase b (d `div` h) + 1
in fromRat (e0-e) (n % (d `div` (b^e)))
else if abs n > h then
integerLogBase :: Integer -> Integer -> Int
integerLogBase b i =
if i < b then
- 0
+ 0
else
-- Try squaring the base first to cut down the number of divisions.
- let l = 2 * integerLogBase (b*b) i
+ let l = 2 * integerLogBase (b*b) i
doDiv :: Integer -> Int -> Int
doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
--- /dev/null
+\section{SST: the strict state transformer monad}
+%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+#include "HsVersions.h"
+
+module SST(
+ SST(..), SST_R, FSST(..), FSST_R,
+
+ _runSST,
+ thenSST, thenSST_, returnSST,
+ thenFSST, thenFSST_, returnFSST, failFSST,
+ recoverFSST, recoverSST, fixFSST,
+
+ MutableVar(..), _MutableArray,
+ newMutVarSST, readMutVarSST, writeMutVarSST
+ ) where
+
+import PreludeGlaST( MutableVar(..), _MutableArray(..) )
+
+CHK_Ubiq() -- debugging consistency check
+\end{code}
+
+\begin{code}
+data SST_R s r = SST_R r (State# s)
+type SST s r = State# s -> SST_R s r
+\end{code}
+
+\begin{code}
+-- Type of runSST should be builtin ...
+-- runSST :: forall r. (forall s. SST s r) -> r
+
+_runSST :: SST _RealWorld r -> r
+_runSST m = case m realWorld# of SST_R r s -> r
+
+
+thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
+{-# INLINE thenSST #-}
+-- Hence:
+-- thenSST :: SST s r -> (r -> SST s r') -> SST s r'
+-- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
+
+thenSST m k s = case m s of { SST_R r s' -> k r s' }
+
+thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
+{-# INLINE thenSST_ #-}
+-- Hence:
+-- thenSST_ :: SST s r -> SST s r' -> SST s r'
+-- and thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
+
+thenSST_ m k s = case m s of { SST_R r s' -> k s' }
+
+returnSST :: r -> SST s r
+{-# INLINE returnSST #-}
+returnSST r s = SST_R r s
+\end{code}
+
+
+\section{FSST: the failable strict state transformer monad}
+%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+data FSST_R s r err = FSST_R_OK r (State# s)
+ | FSST_R_Fail err (State# s)
+
+type FSST s r err = State# s -> FSST_R s r err
+\end{code}
+
+\begin{code}
+thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
+{-# INLINE thenFSST #-}
+thenFSST m k s = case m s of
+ FSST_R_OK r s' -> k r s'
+ FSST_R_Fail err s' -> FSST_R_Fail err s'
+
+thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err
+{-# INLINE thenFSST_ #-}
+thenFSST_ m k s = case m s of
+ FSST_R_OK r s' -> k s'
+ FSST_R_Fail err s' -> FSST_R_Fail err s'
+
+returnFSST :: r -> FSST s r err
+{-# INLINE returnFSST #-}
+returnFSST r s = FSST_R_OK r s
+
+failFSST :: err -> FSST s r err
+{-# INLINE failFSST #-}
+failFSST err s = FSST_R_Fail err s
+
+recoverFSST :: (err -> FSST s r err)
+ -> FSST s r err
+ -> FSST s r err
+recoverFSST recovery_fn m s
+ = case m s of
+ FSST_R_OK r s' -> FSST_R_OK r s'
+ FSST_R_Fail err s' -> recovery_fn err s'
+
+recoverSST :: (err -> SST s r)
+ -> FSST s r err
+ -> SST s r
+recoverSST recovery_fn m s
+ = case m s of
+ FSST_R_OK r s' -> SST_R r s'
+ FSST_R_Fail err s' -> recovery_fn err s'
+
+fixFSST :: (r -> FSST s r err) -> FSST s r err
+fixFSST m s = result
+ where
+ result = m loop s
+ FSST_R_OK loop _ = result
+\end{code}
+
+Mutables
+~~~~~~~~
+Here we implement mutable variables. ToDo: get rid of the array impl.
+
+\begin{code}
+newMutVarSST :: a -> SST s (MutableVar s a)
+newMutVarSST init s#
+ = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
+ SST_R (_MutableArray vAR_IXS arr#) s2# }
+ where
+ vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
+
+readMutVarSST :: MutableVar s a -> SST s a
+readMutVarSST (_MutableArray _ var#) s#
+ = case readArray# var# 0# s# of { StateAndPtr# s2# r ->
+ SST_R r s2# }
+
+writeMutVarSST :: MutableVar s a -> a -> SST s ()
+writeMutVarSST (_MutableArray _ var#) val s#
+ = case writeArray# var# 0# val s# of { s2# ->
+ SST_R () s2# }
+\end{code}
+
--- /dev/null
+Things which are ubiquitous in the GHC compiler.
+
+\begin{code}
+interface Ubiq where
+
+import PreludePS(_PackedString)
+
+import Bag ( Bag )
+import BinderInfo ( BinderInfo )
+import Class ( GenClass, GenClassOp, Class(..), ClassOp )
+import CmdLineOpts ( SimplifierSwitch, SwitchResult )
+import CoreSyn ( GenCoreArg, GenCoreBinder, GenCoreBinding, GenCoreExpr,
+ GenCoreCaseAlts, GenCoreCaseDefault
+ )
+import CoreUnfold ( UnfoldingDetails, UnfoldingGuidance )
+import CostCentre ( CostCentre )
+import FiniteMap ( FiniteMap )
+import HsCore ( UnfoldingCoreExpr )
+import HsPat ( OutPat )
+import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas,
+ InstancePragmas
+ )
+import Id ( StrictnessMark, GenId, Id(..) )
+import IdInfo ( IdInfo, OptIdInfo(..), DeforestInfo, Demand, StrictnessInfo, UpdateInfo )
+import Kind ( Kind )
+import Literal ( Literal )
+import Maybes ( MaybeErr )
+import MatchEnv ( MatchEnv )
+import Name ( Name )
+import NameTypes ( FullName, ShortName )
+import Outputable ( ExportFlag, NamedThing(..), Outputable(..) )
+import PprStyle ( PprStyle )
+import PragmaInfo ( PragmaInfo )
+import Pretty ( PrettyRep )
+import PrimOp ( PrimOp )
+import PrimRep ( PrimRep )
+import ProtoName ( ProtoName )
+import SrcLoc ( SrcLoc )
+import TcType ( TcMaybe )
+import TyCon ( TyCon, Arity(..) )
+import TyVar ( GenTyVar, TyVar(..) )
+import Type ( GenType, Type(..) )
+import UniqFM ( UniqFM )
+import UniqSupply ( UniqSupply )
+import Unique ( Unique )
+import Usage ( GenUsage, Usage(..) )
+import Util ( Ord3(..) )
+
+-- All the classes in GHC go; life is just too short
+-- to try to contain their visibility.
+
+class NamedThing a where
+ getExportFlag :: a -> ExportFlag
+ isLocallyDefined :: a -> Bool
+ getOrigName :: a -> (_PackedString, _PackedString)
+ getOccurrenceName :: a -> _PackedString
+ getInformingModules :: a -> [_PackedString]
+ getSrcLoc :: a -> SrcLoc
+ getItsUnique :: a -> Unique
+ fromPreludeCore :: a -> Bool
+class OptIdInfo a where
+ noInfo :: a
+ getInfo :: IdInfo -> a
+ addInfo :: IdInfo -> a -> IdInfo
+ ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
+class Ord3 a where
+ cmp :: a -> a -> Int#
+class Outputable a where
+ ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
+
+-- For datatypes, we ubiquitize those types that (a) are
+-- used everywhere and (b) the compiler doesn't lose much
+-- optimisation-wise by not seeing their pragma-gunk.
+
+data Bag a
+data BinderInfo
+data ClassOpPragmas a
+data ClassPragmas a
+data CostCentre
+data DataPragmas a
+data DeforestInfo
+data Demand
+data ExportFlag
+data FiniteMap a b
+data FullName -- NB: fails the optimisation criterion
+data GenClass a b
+data GenClassOp a
+data GenCoreArg a b c
+data GenCoreBinder a b c
+data GenCoreBinding a b c d
+data GenCoreCaseAlts a b c d
+data GenCoreCaseDefault a b c d
+data GenCoreExpr a b c d
+data GenId a -- NB: fails the optimisation criterion
+data GenPragmas a
+data GenTyVar a -- NB: fails the optimisation criterion
+data GenType a b
+data GenUsage a
+data IdInfo
+data InstancePragmas a
+data Kind
+data Literal
+data MaybeErr a b
+data MatchEnv a b
+data Name
+data OutPat a b c
+data PprStyle
+data PragmaInfo
+data PrettyRep
+data PrimOp
+data PrimRep -- NB: an enumeration
+data ProtoName
+data ShortName -- NB: fails the optimisation criterion
+data SimplifierSwitch
+data SrcLoc
+data StrictnessInfo
+data StrictnessMark
+data SwitchResult
+data TcMaybe s
+data TyCon
+data UnfoldingCoreExpr a
+data UniqFM a
+data UpdateInfo
+data UniqSupply
+data UnfoldingDetails
+data UnfoldingGuidance
+data Unique -- NB: fails the optimisation criterion
+
+-- don't get clever and unexpand some of these synonyms
+-- (GHC 0.26 will barf)
+type Arity = Int
+type Class = GenClass (GenTyVar (GenUsage Unique)) Unique
+type ClassOp = GenClassOp (GenType (GenTyVar (GenUsage Unique)) Unique)
+type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
+type Type = GenType (GenTyVar (GenUsage Unique)) Unique
+type TyVar = GenTyVar (GenUsage Unique)
+type Usage = GenUsage Unique
+\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface UniqFM where
-import Id(Id)
-import Maybes(Labda)
-import Outputable(NamedThing)
-import TyVar(TyVar)
-import Unique(Unique)
-data Id
-data TyVar
-data UniqFM a
-data Unique
-addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b
-addToUFM_Directly :: UniqFM a -> Unique -> a -> UniqFM a
-delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b
-delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b
-eltsUFM :: UniqFM a -> [a]
-emptyUFM :: UniqFM a
-filterUFM :: (a -> Bool) -> UniqFM a -> UniqFM a
-intersectUFM :: UniqFM a -> UniqFM a -> UniqFM a
-isNullUFM :: UniqFM a -> Bool
-listToUFM :: NamedThing a => [(a, b)] -> UniqFM b
-listToUFM_Directly :: [(Unique, a)] -> UniqFM a
-lookupDirectlyUFM :: UniqFM a -> Unique -> Labda a
-lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b
-mapUFM :: (a -> b) -> UniqFM a -> UniqFM b
-minusUFM :: UniqFM a -> UniqFM a -> UniqFM a
-plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
-plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
-singletonDirectlyUFM :: Unique -> a -> UniqFM a
-singletonUFM :: NamedThing a => a -> b -> UniqFM b
-sizeUFM :: UniqFM a -> Int
-ufmToList :: UniqFM a -> [(Unique, a)]
-
%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[UniqFM]{Specialised finite maps, for things with @Uniques@}
Based on @FiniteMaps@ (as you would expect).
Basically, the things need to be in class @NamedThing@, and we use the
-@getTheUnique@ method to grab their @Uniques@.
+@getItsUnique@ method to grab their @Uniques@.
(A similar thing to @UniqSet@, as opposed to @Set@.)
-@IdEnv@ and @TyVarEnv@ are the (backward-compatible?) specialisations
-of this stuff for Ids and TyVars, respectively.
-
\begin{code}
#if defined(COMPILING_GHC)
#include "HsVersions.h"
listToUFM,
listToUFM_Directly,
addToUFM,
- IF_NOT_GHC(addListToUFM COMMA)
+ addListToUFM,
addToUFM_Directly,
+ addListToUFM_Directly,
IF_NOT_GHC(addToUFM_C COMMA)
IF_NOT_GHC(addListToUFM_C COMMA)
delFromUFM,
filterUFM,
sizeUFM,
isNullUFM,
- lookupUFM,
- lookupDirectlyUFM,
- IF_NOT_GHC(lookupWithDefaultUFM COMMA)
+ lookupUFM, lookupUFM_Directly,
+ lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM,
- ufmToList,
+ ufmToList
-- to make the interface self-sufficient
- Id, TyVar, Unique
- IF_ATTACK_PRAGMAS(COMMA u2i) -- profiling
) where
-import AbsUniType -- for specialisation to TyVars
-import Id -- for specialisation to Ids
-import IdInfo -- sigh
-import Maybes ( maybeToBool, Maybe(..) )
-import Name
-import Outputable
-import Unique ( u2i, mkUniqueGrimily, Unique )
+#if defined(COMPILING_GHC)
+CHK_Ubiq() -- debugging consistency check
+#endif
+
+import Unique ( Unique, u2i, mkUniqueGrimily )
import Util
+import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+import Pretty ( Pretty(..), PrettyRep )
+import PprStyle ( PprStyle )
+import SrcLoc ( SrcLoc )
+
#if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc ( Reg )
#define IF_NCG(a) a
#else
#define IF_NCG(a) {--}
%* *
%************************************************************************
-We use @FiniteMaps@, with a (@getTheUnique@-able) @Unique@ as ``key''.
+We use @FiniteMaps@, with a (@getItsUnique@-able) @Unique@ as ``key''.
\begin{code}
emptyUFM :: UniqFM elt
sizeUFM :: UniqFM elt -> Int
lookupUFM :: NamedThing key => UniqFM elt -> key -> Maybe elt
-lookupDirectlyUFM -- when you've got the Unique already
+lookupUFM_Directly -- when you've got the Unique already
:: UniqFM elt -> Unique -> Maybe elt
lookupWithDefaultUFM
:: NamedThing key => UniqFM elt -> elt -> key -> elt
+lookupWithDefaultUFM_Directly
+ :: UniqFM elt -> elt -> Unique -> elt
eltsUFM :: UniqFM elt -> [elt]
ufmToList :: UniqFM elt -> [(Unique, elt)]
%************************************************************************
\begin{code}
+#if 0
+
type IdFinMap elt = UniqFM elt
type TyVarFinMap elt = UniqFM elt
type NameFinMap elt = UniqFM elt
type RegFinMap elt = UniqFM elt
-\end{code}
-\begin{code}
#ifdef __GLASGOW_HASKELL__
-- I don't think HBC was too happy about this (WDP 94/10)
#-}
#endif {- __GLASGOW_HASKELL__ -}
+#endif {- 0 -}
\end{code}
%************************************************************************
\begin{code}
emptyUFM = EmptyUFM
-singletonUFM key elt = mkLeafUFM (u2i (getTheUnique key)) elt
+singletonUFM key elt = mkLeafUFM (u2i (getItsUnique key)) elt
singletonDirectlyUFM key elt = mkLeafUFM (u2i key) elt
listToUFM key_elt_pairs
addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
addToUFM_C combiner fm key elt
- = insert_ele combiner fm (u2i (getTheUnique key)) elt
+ = insert_ele combiner fm (u2i (getItsUnique key)) elt
addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
+addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
addListToUFM_C combiner fm key_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getTheUnique k)) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getItsUnique k)) e)
fm key_elt_pairs
addListToUFM_directly_C combiner fm uniq_elt_pairs
\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst
-delFromUFM fm key = delete fm (u2i (getTheUnique key))
+delFromUFM fm key = delete fm (u2i (getItsUnique key))
delete EmptyUFM _ = EmptyUFM
delete fm key = del_ele fm
del_ele nd@(NodeUFM j p t1 t2)
| j _GT_ key
= mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2
- | otherwise
+ | otherwise
= mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2)
del_ele _ = panic "Found EmptyUFM FM when rec-deleting"
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
+ --
mix_branches (SameRoot)
= mkSSNodeUFM (NodeUFMData j p)
(mix_trees t1 t1')
-- t1 t2 t1' t2' t1 t2 + j'
-- / \
-- t1' t2'
- mix_branches (LeftRoot Left) -- | trace "LL" True
+ mix_branches (LeftRoot Leftt) -- | trace "LL" True
= mkSLNodeUFM
(NodeUFMData j p)
- (mix_trees t1 right_t)
+ (mix_trees t1 right_t)
t2
- mix_branches (LeftRoot Right) -- | trace "LR" True
+ mix_branches (LeftRoot Rightt) -- | trace "LR" True
= mkLSNodeUFM
(NodeUFMData j p)
t1
- (mix_trees t2 right_t)
+ (mix_trees t2 right_t)
- mix_branches (RightRoot Left) -- | trace "RL" True
+ mix_branches (RightRoot Leftt) -- | trace "RL" True
= mkSLNodeUFM
(NodeUFMData j' p')
- (mix_trees left_t t1')
+ (mix_trees left_t t1')
t2'
- mix_branches (RightRoot Right) -- | trace "RR" True
+ mix_branches (RightRoot Rightt) -- | trace "RR" True
= mkLSNodeUFM
(NodeUFMData j' p')
t1'
- (mix_trees left_t t2')
+ (mix_trees left_t t2')
mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt"
\end{code}
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 t2
- --
- --
+ --
+ --
-- Fast, Ehh !
--
minus_branches (NewRoot nd _) = left_t
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 + t1' t2 + t2'
- --
+ --
minus_branches (SameRoot)
= mkSSNodeUFM (NodeUFMData j p)
(minus_trees t1 t1')
--
-- The left is above the right
--
- minus_branches (LeftRoot Left)
+ minus_branches (LeftRoot Leftt)
= mkSLNodeUFM
(NodeUFMData j p)
- (minus_trees t1 right_t)
+ (minus_trees t1 right_t)
t2
- minus_branches (LeftRoot Right)
+ minus_branches (LeftRoot Rightt)
= mkLSNodeUFM
(NodeUFMData j p)
t1
- (minus_trees t2 right_t)
+ (minus_trees t2 right_t)
--
-- The right is above the left
--
- minus_branches (RightRoot Left)
+ minus_branches (RightRoot Leftt)
= minus_trees left_t t1'
- minus_branches (RightRoot Right)
+ minus_branches (RightRoot Rightt)
= minus_trees left_t t2'
minus_trees _ _ = panic "EmptyUFM found when insering into plusInt"
where
-- Given a disjoint j,j' (p >^ p' && p' >^ p):
--
- -- j j'
+ -- j j'
-- / \ + / \ ==> EmptyUFM
- -- t1 t2 t1' t2'
- --
+ -- t1 t2 t1' t2'
+ --
-- Fast, Ehh !
--
intersect_branches (NewRoot nd _) = EmptyUFM
-- j j' j
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1 x t1' t2 x t2'
- --
+ --
intersect_branches (SameRoot)
= mkSSNodeUFM (NodeUFMData j p)
(intersect_trees t1 t1')
-- j j' t2 + j'
-- / \ + / \ ==> / \
-- t1 t2 t1' t2' t1' t2'
- --
+ --
-- This does cut down the search space quite a bit.
-
- intersect_branches (LeftRoot Left)
+
+ intersect_branches (LeftRoot Leftt)
= intersect_trees t1 right_t
- intersect_branches (LeftRoot Right)
+ intersect_branches (LeftRoot Rightt)
= intersect_trees t2 right_t
- intersect_branches (RightRoot Left)
+ intersect_branches (RightRoot Leftt)
= intersect_trees left_t t1'
- intersect_branches (RightRoot Right)
+ intersect_branches (RightRoot Rightt)
= intersect_trees left_t t2'
intersect_trees x y = panic ("EmptyUFM found when intersecting trees")
Lookup up a binary tree is easy (and fast).
\begin{code}
-lookupUFM fm key = lookup fm (u2i (getTheUnique key))
-lookupDirectlyUFM fm key = lookup fm (u2i key)
+lookupUFM fm key = lookup fm (u2i (getItsUnique key))
+lookupUFM_Directly fm key = lookup fm (u2i key)
lookupWithDefaultUFM fm deflt key
- = case lookup fm (u2i (getTheUnique key)) of
+ = case lookup fm (u2i (getItsUnique key)) of
+ Nothing -> deflt
+ Just elt -> elt
+
+lookupWithDefaultUFM_Directly fm deflt key
+ = case lookup fm (u2i key) of
Nothing -> deflt
Just elt -> elt
filter_tree f nd@(NodeUFM j p t1 t2)
= mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2)
-filter_tree f lf@(LeafUFM i obj)
+filter_tree f lf@(LeafUFM i obj)
| f obj = lf
| otherwise = EmptyUFM
\end{code}
This is the information used when computing new NodeUFMs.
\begin{code}
-data Side = Left | Right
+data Side = Leftt | Rightt -- NB: avoid 1.3 names "Left" and "Right"
data CommonRoot
= LeftRoot Side -- which side is the right down ?
| RightRoot Side -- which side is the left down ?
| otherwise -> NewRoot nd (j _GT_ j2)
where
decideSide :: Bool -> Side
- decideSide True = Left
- decideSide False = Right
+ decideSide True = Leftt
+ decideSide False = Rightt
\end{code}
This might be better in Util.lhs ?
{-# INLINE shiftR_ #-}
shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p)
shiftR_ n p = word2Int#((int2Word# n) `shiftr` p)
-# if __GLASGOW_HASKELL__ >= 23
where
shiftr x y = shiftRA# x y
-# else
- shiftr x y = shiftR# x y
-# endif
#else {- not GHC -}
shiftL_ n p = n * (2 ^ p)
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface UniqSet where
-import Id(Id)
-import Name(Name)
-import NameTypes(FullName, ShortName)
-import Outputable(NamedThing)
-import PreludePS(_PackedString)
-import TyCon(TyCon)
-import TyVar(TyVar)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data Id
-type IdSet = UniqFM Id
-data Name
-type NameSet = UniqFM Name
-data TyVar
-type TyVarSet = UniqFM TyVar
-data UniqFM a
-type UniqSet a = UniqFM a
-data Unique
-elementOfUniqSet :: NamedThing a => a -> UniqFM a -> Bool
-emptyUniqSet :: UniqFM a
-intersectUniqSets :: UniqFM a -> UniqFM a -> UniqFM a
-isEmptyUniqSet :: UniqFM a -> Bool
-mapUniqSet :: NamedThing b => (a -> b) -> UniqFM a -> UniqFM b
-minusUniqSet :: UniqFM a -> UniqFM a -> UniqFM a
-mkUniqSet :: NamedThing a => [a] -> UniqFM a
-singletonUniqSet :: NamedThing a => a -> UniqFM a
-unionManyUniqSets :: [UniqFM a] -> UniqFM a
-unionUniqSets :: UniqFM a -> UniqFM a -> UniqFM a
-uniqSetToList :: UniqFM a -> [a]
-
%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[UniqSet]{Specialised sets, for things with @Uniques@}
Basically, the things need to be in class @NamedThing@.
-We also export specialisations for @Ids@ and @TyVars@.
-
\begin{code}
#include "HsVersions.h"
mkUniqSet, uniqSetToList, emptyUniqSet, singletonUniqSet,
unionUniqSets, unionManyUniqSets, minusUniqSet,
- elementOfUniqSet, mapUniqSet,
- intersectUniqSets, isEmptyUniqSet,
-
- -- specalised for Ids:
- IdSet(..),
-
- -- specalised for TyVars:
- TyVarSet(..),
-
- -- specalised for Names:
- NameSet(..),
-
- -- to make the interface self-sufficient
- Id, TyVar, Name,
-
- UniqFM, Unique
-
- -- and to be pragma friendly
-#ifdef USE_ATTACK_PRAGMAS
- , emptyUFM, intersectUFM, isNullUFM, minusUFM, singletonUFM,
- plusUFM, eltsUFM,
- u2i
-#endif
+ elementOfUniqSet, mapUniqSet, intersectUniqSets,
+ isEmptyUniqSet
) where
+CHK_Ubiq() -- debugging consistency check
+
+import Maybes ( maybeToBool, Maybe )
import UniqFM
-import Id -- for specialisation to Ids
-import IdInfo -- sigh
-import Maybes ( maybeToBool, Maybe(..) )
-import Name
-import Outputable
-import AbsUniType -- for specialisation to TyVars
-import Util
+import Unique ( Unique )
+import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+import SrcLoc ( SrcLoc )
+import Pretty ( Pretty(..), PrettyRep )
+import PprStyle ( PprStyle )
+import Util ( Ord3(..) )
+
#if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc ( Reg )
#define IF_NCG(a) a
#else
#define IF_NCG(a) {--}
%* *
%************************************************************************
-We use @UniqFM@, with a (@getTheUnique@-able) @Unique@ as ``key''
+We use @UniqFM@, with a (@getItsUnique@-able) @Unique@ as ``key''
and the thing itself as the ``value'' (for later retrieval).
\begin{code}
singletonUniqSet x = MkUniqSet (singletonUFM x x)
uniqSetToList :: UniqSet a -> [a]
-uniqSetToList (MkUniqSet set) = BSCC("uniqSetToList") eltsUFM set ESCC
+uniqSetToList (MkUniqSet set) = eltsUFM set
mkUniqSet :: NamedThing a => [a] -> UniqSet a
mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs])
@IdSet@ is a specialised version, optimised for sets of Ids.
\begin{code}
-type IdSet = UniqSet Id
-type TyVarSet = UniqSet TyVar
-type NameSet = UniqSet Name
+--type NameSet = UniqSet Name
+--type GenTyVarSet flexi = UniqSet (GenTyVar flexi)
+--type GenIdSet ty = UniqSet (GenId ty)
+
#if ! OMIT_NATIVE_CODEGEN
-type RegSet = UniqSet Reg
+--type RegSet = UniqSet Reg
#endif
+#if 0
#if __GLASGOW_HASKELL__
- -- avoid hbc bug (0.999.7)
{-# SPECIALIZE
- singletonUniqSet :: Id -> IdSet,
- TyVar -> TyVarSet,
+ singletonUniqSet :: GenId ty -> GenIdSet ty,
+ GenTyVar flexi -> GenTyVarSet flexi,
Name -> NameSet
IF_NCG(COMMA Reg -> RegSet)
#-}
{-# SPECIALIZE
- mkUniqSet :: [Id] -> IdSet,
- [TyVar] -> TyVarSet,
+ mkUniqSet :: [GenId ty] -> GenIdSet ty,
+ [GenTyVar flexi] -> GenTyVarSet flexi,
[Name] -> NameSet
IF_NCG(COMMA [Reg] -> RegSet)
#-}
{-# SPECIALIZE
- elementOfUniqSet :: Id -> IdSet -> Bool,
- TyVar -> TyVarSet -> Bool,
+ elementOfUniqSet :: GenId ty -> GenIdSet ty -> Bool,
+ GenTyVar flexi -> GenTyVarSet flexi -> Bool,
Name -> NameSet -> Bool
IF_NCG(COMMA Reg -> RegSet -> Bool)
#-}
{-# SPECIALIZE
- mapUniqSet :: (Id -> Id) -> IdSet -> IdSet,
- (TyVar -> TyVar) -> TyVarSet -> TyVarSet,
+ mapUniqSet :: (GenId ty -> GenId ty) -> GenIdSet ty -> GenIdSet ty,
+ (GenTyVar flexi -> GenTyVar flexi) -> GenTyVarSet flexi -> GenTyVarSet flexi,
(Name -> Name) -> NameSet -> NameSet
IF_NCG(COMMA (Reg -> Reg) -> RegSet -> RegSet)
#-}
#endif
+#endif
\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Unpretty where
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
-import PreludePS(_PackedString)
-import Pretty(PprStyle(..))
-import Stdio(_FILE)
-data CSeq
-data GlobalSwitch
-data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char])
-type Unpretty = CSeq
-uppAbove :: CSeq -> CSeq -> CSeq
-uppAboves :: [CSeq] -> CSeq
-uppAppendFile :: _FILE -> Int -> CSeq -> _State _RealWorld -> ((), _State _RealWorld)
-uppBeside :: CSeq -> CSeq -> CSeq
-uppBesides :: [CSeq] -> CSeq
-uppCat :: [CSeq] -> CSeq
-uppChar :: Char -> CSeq
-uppComma :: CSeq
-uppEquals :: CSeq
-uppInt :: Int -> CSeq
-uppInteger :: Integer -> CSeq
-uppInterleave :: CSeq -> [CSeq] -> CSeq
-uppIntersperse :: CSeq -> [CSeq] -> CSeq
-uppLbrack :: CSeq
-uppLparen :: CSeq
-uppNest :: Int -> CSeq -> CSeq
-uppNil :: CSeq
-uppPStr :: _PackedString -> CSeq
-uppRbrack :: CSeq
-uppRparen :: CSeq
-uppSP :: CSeq
-uppSemi :: CSeq
-uppSep :: [CSeq] -> CSeq
-uppShow :: Int -> CSeq -> [Char]
-uppStr :: [Char] -> CSeq
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Unpretty]{Unpretty-printing data type}
module Unpretty (
Unpretty(..),
- PprStyle(..), -- re-exported from Pretty
- uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger, --UNUSED: uppDouble,
- uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, -- UNUSED: upp'SP,
+
+ uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger,
+ uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen,
uppSemi, uppComma, uppEquals,
uppCat, uppBeside, uppBesides, uppAbove, uppAboves,
- uppNest, uppSep, uppInterleave, uppIntersperse, --UNUSED: uppHang,
+ uppNest, uppSep, uppInterleave, uppIntersperse,
uppShow,
-#ifdef __GLASGOW_HASKELL__
uppAppendFile,
- IF_ATTACK_PRAGMAS(cAppendFile COMMA)
- IF_ATTACK_PRAGMAS(cInt COMMA)
-#endif
-#ifdef DPH
- unprettyToStr,
-#endif {- Data Parallel Haskell -}
-- abstract type, to complete the interface...
- CSeq, GlobalSwitch
+ CSeq
) where
+CHK_Ubiq() -- debugging consistency check
+
import CharSeq
-import Outputable
-import Pretty ( PprStyle(..), Pretty(..), GlobalSwitch )
-import Util
\end{code}
Same interface as @Pretty@, but doesn't do anything.
\begin{code}
uppNil :: Unpretty
uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, uppSemi, uppComma, uppEquals :: Unpretty
---UNUSED: upp'SP :: Unpretty
uppStr :: [Char] -> Unpretty
uppPStr :: FAST_STRING -> Unpretty
uppChar :: Char -> Unpretty
uppInt :: Int -> Unpretty
uppInteger :: Integer -> Unpretty
---UNUSED:uppDouble :: Double -> Unpretty
uppBeside :: Unpretty -> Unpretty -> Unpretty
uppBesides :: [Unpretty] -> Unpretty
uppInterleave :: Unpretty -> [Unpretty] -> Unpretty
uppIntersperse :: Unpretty -> [Unpretty] -> Unpretty -- no spaces between
uppSep :: [Unpretty] -> Unpretty
---UNUSED:uppHang :: Unpretty -> Int -> Unpretty -> Unpretty
uppNest :: Int -> Unpretty -> Unpretty
uppShow :: Int -> Unpretty -> [Char]
-#ifdef __GLASGOW_HASKELL__
uppAppendFile :: _FILE -> Int -> Unpretty -> PrimIO ()
-#endif
\end{code}
%************************************************
\begin{code}
uppShow _ p = cShow p
-#ifdef __GLASGOW_HASKELL__
uppAppendFile f _ p = cAppendFile f p
-#endif
uppNil = cNil
uppStr s = cStr s
uppInt n = cInt n
uppInteger n = cStr (show n)
---UNUSED:uppDouble n = cStr (show n)
uppSP = cCh ' '
---UNUSED:upp'SP = cStr ", "
uppLbrack = cCh '['
uppRbrack = cCh ']'
uppLparen = cCh '('
uppAboves (p:ps) = p `cAppend` (cCh '\n') `cAppend` (uppAboves ps)
uppNest n p = p
-\end{code}
-
-\begin{code}
---UNUSED: uppHang p1 n p2 = ppBesideSP p1 p2
uppSep ps = uppBesides ps
\end{code}
-
-\begin{code}
-#ifdef DPH
-unprettyToStr:: Unpretty -> String
-unprettyToStr thing = uppShow 80 thing
-#endif {- Data Parallel Haskell -}
-\end{code}
+++ /dev/null
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
-interface Util where
-import CharSeq(CSeq)
-import Maybes(Labda(..))
-import PreludePS(_PackedString)
-import Pretty(Delay, Pretty(..), PrettyRep)
-data Labda a = Hamna | Ni a
-type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep
-assertPanic :: [Char] -> Int -> a
-assoc :: Eq a => [Char] -> [(a, b)] -> a -> b
-cmpPString :: _PackedString -> _PackedString -> Int#
-equivClasses :: (a -> a -> Int#) -> [a] -> [[a]]
-hasNoDups :: Eq a => [a] -> Bool
-isIn :: Eq a => [Char] -> a -> [a] -> Bool
-isSingleton :: [a] -> Bool
-isn'tIn :: Eq a => [Char] -> a -> [a] -> Bool
-lengthExceeds :: [a] -> Int -> Bool
-mapAccumB :: (b -> c -> a -> (b, c, d)) -> b -> c -> [a] -> (b, c, [d])
-mapAccumL :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c])
-mapAccumR :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c])
-nOfThem :: Int -> a -> [a]
-naturalMergeSortLe :: (a -> a -> Bool) -> [a] -> [a]
-panic :: [Char] -> a
-pprPanic :: [Char] -> (Int -> Bool -> PrettyRep) -> a
-pprTrace :: [Char] -> (Int -> Bool -> PrettyRep) -> a -> a
-removeDups :: (a -> a -> Int#) -> [a] -> ([a], [[a]])
-runs :: (a -> a -> Bool) -> [a] -> [[a]]
-sortLt :: (a -> a -> Bool) -> [a] -> [a]
-transitiveClosure :: (a -> [a]) -> (a -> a -> Bool) -> [a] -> [a]
-unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
-zipEqual :: [a] -> [b] -> [(a, b)]
-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Util]{Highly random utility functions}
#endif
-- general list processing
IF_NOT_GHC(forall COMMA exists COMMA)
- zipEqual, nOfThem, lengthExceeds, isSingleton,
+ zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
+ zipLazy,
+ nOfThem, lengthExceeds, isSingleton,
#if defined(COMPILING_GHC)
isIn, isn'tIn,
#endif
-- association lists
assoc,
-#ifdef USE_SEMANTIQUE_STRANAL
- clookup, clookrepl, elemIndex, (\\\),
-#endif
-- duplicate handling
hasNoDups, equivClasses, runs, removeDups,
mapAccumL, mapAccumR, mapAccumB,
-- comparisons
+ Ord3(..), thenCmp, cmpList,
IF_NOT_GHC(cmpString COMMA)
#ifdef USE_FAST_STRINGS
cmpPString,
-- error handling
#if defined(COMPILING_GHC)
- , panic, pprPanic, pprTrace
+ , panic, panic#, pprPanic, pprPanic#, pprTrace
# ifdef DEBUG
, assertPanic
# endif
# endif
#endif
-#ifdef USE_ATTACK_PRAGMAS
- -- as more-or-less of a *HACK*, Util exports
- -- many types abstractly, so that pragmas will be
- -- able to see them (given that most modules
- -- import Util).
- ,
- AbstractC,
- ArgUsage,
- ArgUsageInfo,
- ArithSeqInfo,
- ArityInfo,
- Bag,
- BasicLit,
- Bind,
- BinderInfo,
- Binds,
- CAddrMode,
- CExprMacro,
- CLabel,
- CSeq,
- CStmtMacro,
- CcKind,
- Class,
- ClassDecl,
- ClassOp,
- ClassOpPragmas,
- ClassPragmas,
- ClosureInfo,
- ConDecl,
- CoreArg,
- CoreAtom,
- CoreBinding,
- CoreCaseAlternatives,
- CoreCaseDefault,
- CoreExpr,
- CostCentre,
- DataPragmas,
- DataTypeSig,
- DefaultDecl,
- DeforestInfo,
- Delay,
- Demand,
- DemandInfo,
- DuplicationDanger,
- EnclosingCcDetails,
- EndOfBlockInfo,
- ExportFlag,
- Expr,
- FBConsum,
- FBProd,
- FBType,
- FBTypeInfo,
- FiniteMap,
- FixityDecl,
- FormSummary,
- FullName,
- FunOrArg,
- GRHS,
- GRHSsAndBinds,
- GenPragmas,
- GlobalSwitch,
- HeapOffset,
- IE,
- Id,
- IdDetails,
- IdEnv(..), -- UGH
- IdInfo,
- IdVal,
- IfaceImportDecl,
- ImpStrictness,
- ImpUnfolding,
- ImportedInterface,
- InPat,
- InsideSCC,
- Inst,
- InstDecl,
- InstOrigin,
- InstTemplate,
- InstTy,
- InstancePragmas,
- Interface,
- IsDupdCC, IsCafCC,
- LambdaFormInfo,
- Literal,
- MagicId,
- MagicUnfoldingFun,
- Match,
- Module,
- MonoBinds,
- MonoType,
- Name,
- NamedThing(..), -- SIGH
- OptIdInfo(..), -- SIGH
- OrdList,
- Outputable(..), -- SIGH
- OverloadedLit,
- PolyType,
- PprStyle,
- PrimKind,
- PrimOp,
- ProtoName,
- Provenance,
- Qual,
- RegRelative,
- Renaming,
- ReturnInfo,
- SMRep,
- SMSpecRepKind,
- SMUpdateKind,
- Sequel,
- ShortName,
- Sig,
- SimplCount,
- SimplEnv,
- SimplifierSwitch,
- SpecEnv,
- SpecInfo,
- SpecialisedInstanceSig,
- SplitUniqSupply,
- SrcLoc,
- StableLoc,
- StandardFormInfo,
- StgAtom,
- StgBinderInfo,
- StgBinding,
- StgCaseAlternatives,
- StgCaseDefault,
- StgExpr,
- StgRhs,
- StrictnessInfo,
- StubFlag,
- SwitchResult,
- TickType,
- TyCon,
- TyDecl,
- TyVar,
- TyVarEnv(..),
- TyVarTemplate,
- TypePragmas,
- TypecheckedPat,
- UfCostCentre,
- UfId,
- UnfoldEnv,
- UnfoldItem,
- UnfoldConApp,
- UnfoldingCoreAlts,
- UnfoldingCoreAtom,
- UnfoldingCoreBinding,
- UnfoldingCoreDefault,
- UnfoldingCoreExpr,
- UnfoldingDetails,
- UnfoldingGuidance,
- UnfoldingPrimOp,
- UniType,
- UniqFM,
- Unique,
- UniqueSupply,
- UpdateFlag,
- UpdateInfo,
- VolatileLoc,
-
-#if ! OMIT_NATIVE_CODEGEN
- Reg,
- CodeSegment,
- RegLoc,
- StixReg,
- StixTree,
-#endif
-
- getIdUniType, typeOfBasicLit, typeOfPat,
- getIdKind, kindOfBasicLit,
- kindFromType,
-
- eqId, cmpId,
- eqName, cmpName,
- cmpProtoName, eqProtoName,
- cmpByLocalName, eqByLocalName,
- eqUnique, cmpUnique,
- showUnique,
-
- switchIsOn,
-
- ppNil, ppStr, ppInt, ppInteger, ppDouble,
-#if __GLASGOW_HASKELL__ >= 23
- ppRational, --- ???
-#endif
- cNil, cStr, cAppend, cCh, cShow,
-#if __GLASGOW_HASKELL__ >= 23
- cPStr,
-#endif
-
--- mkBlackHoleCLabel,
-
- emptyBag, snocBag,
- emptyFM,
---OLD: emptySet,
- nullSpecEnv,
-
- mkUnknownSrcLoc,
-
- pprCoreBinding, pprCoreExpr, pprTyCon, pprUniType,
-
- tagOf_PrimOp,
- pprPrimOp
-
-#endif {-USE_ATTACK_PRAGMAS-}
) where
#if defined(COMPILING_GHC)
-IMPORT_Trace
+
+CHK_Ubiq() -- debugging consistency check
+
import Pretty
#endif
#if __HASKELL1__ < 3
import Maybes ( Maybe(..) )
#endif
-
-#if defined(COMPILING_GHC)
-import Id
-import IdInfo
-import Outputable
-
-# ifdef USE_ATTACK_PRAGMAS
-
-import AbsCSyn
-import AbsSyn
-import AbsUniType
-import Bag
-import BasicLit
-import BinderInfo
-import CLabelInfo
-import CgBindery
-import CgMonad
-import CharSeq
-import ClosureInfo
-import CmdLineOpts
-import CoreSyn
-import FiniteMap
-import HsCore
-import HsPragmas
-import Inst
-import InstEnv
-import Name
-import NameTypes
-import OrdList
-import PlainCore
-import PrimOps
-import ProtoName
-import CostCentre
-import SMRep
-import SimplEnv
-import SimplMonad
-import SplitUniq
-import SrcLoc
-import StgSyn
-import TyVarEnv
-import UniqFM
-import Unique
-
-# if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc ( Reg )
-import MachDesc
-import Stix
-# endif
-
-# endif {-USE_ATTACK_PRAGMAS-}
-
-#endif
\end{code}
%************************************************************************
exists pred (x:xs) = pred x || exists pred xs
\end{code}
-A paranoid @zip@ that checks the lists are of equal length.
-Alastair Reid thinks this should only happen if DEBUGging on;
-hey, why not?
+A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
+are of equal length. Alastair Reid thinks this should only happen if
+DEBUGging on; hey, why not?
\begin{code}
-zipEqual :: [a] -> [b] -> [(a,b)]
+zipEqual :: [a] -> [b] -> [(a,b)]
+zipWithEqual :: (a->b->c) -> [a]->[b]->[c]
+zipWith3Equal :: (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith4Equal :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
#ifndef DEBUG
-zipEqual a b = zip a b
+zipEqual = zip
+zipWithEqual = zipWith
+zipWith3Equal = zipWith3
+zipWith4Equal = zipWith4
#else
zipEqual [] [] = []
zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs
zipEqual as bs = panic "zipEqual: unequal lists"
+
+zipWithEqual z (a:as) (b:bs) = z a b : zipWithEqual z as bs
+zipWithEqual _ [] [] = []
+zipWithEqual _ _ _ = panic "zipWithEqual: unequal lists"
+
+zipWith3Equal z (a:as) (b:bs) (c:cs)
+ = z a b c : zipWith3Equal z as bs cs
+zipWith3Equal _ [] [] [] = []
+zipWith3Equal _ _ _ _ = panic "zipWith3Equal: unequal lists"
+
+zipWith4Equal z (a:as) (b:bs) (c:cs) (d:ds)
+ = z a b c d : zipWith4Equal z as bs cs ds
+zipWith4Equal _ [] [] [] [] = []
+zipWith4Equal _ _ _ _ _ = panic "zipWith4Equal: unequal lists"
#endif
\end{code}
\begin{code}
+-- zipLazy is lazy in the second list (observe the ~)
+
+zipLazy :: [a] -> [b] -> [(a,b)]
+zipLazy [] ys = []
+zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
+\end{code}
+
+\begin{code}
nOfThem :: Int -> a -> [a]
nOfThem n thing = take n (repeat thing)
# endif {- DEBUG -}
# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isIn :: String -> BasicLit -> [BasicLit] -> Bool #-}
+{-# SPECIALIZE isIn :: String -> Literal -> [Literal] -> Bool #-}
{-# SPECIALIZE isIn :: String -> Class -> [Class] -> Bool #-}
{-# SPECIALIZE isIn :: String -> Id -> [Id] -> Bool #-}
{-# SPECIALIZE isIn :: String -> Int -> [Int] -> Bool #-}
{-# SPECIALIZE assoc :: String -> [(Id, a)] -> Id -> a #-}
{-# SPECIALIZE assoc :: String -> [(Class, a)] -> Class -> a #-}
{-# SPECIALIZE assoc :: String -> [(Name, a)] -> Name -> a #-}
-{-# SPECIALIZE assoc :: String -> [(PrimKind, a)] -> PrimKind -> a #-}
+{-# SPECIALIZE assoc :: String -> [(PrimRep, a)] -> PrimRep -> a #-}
{-# SPECIALIZE assoc :: String -> [(String, a)] -> String -> a #-}
{-# SPECIALIZE assoc :: String -> [(TyCon, a)] -> TyCon -> a #-}
{-# SPECIALIZE assoc :: String -> [(TyVar, a)] -> TyVar -> a #-}
{-# SPECIALIZE assoc :: String -> [(TyVarTemplate, a)] -> TyVarTemplate -> a #-}
-{-# SPECIALIZE assoc :: String -> [(UniType, a)] -> UniType -> a #-}
+{-# SPECIALIZE assoc :: String -> [(Type, a)] -> Type -> a #-}
{-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-}
# endif
#endif
\end{code}
-Given a list of associations one wants to look for the most recent
-association for a given key. A couple of functions follow that cover
-the simple lookup, the lookup with a default value when the key not
-found, and two corresponding functions operating on unzipped lists
-of associations.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-
-clookup :: (Eq a) => [a] -> [b] -> a -> b
-clookup = clookupElse (panic "clookup")
- where
- -- clookupElse :: (Eq a) => b -> [a] -> [b] -> a -> b
- clookupElse d [] [] a = d
- clookupElse d (x:xs) (y:ys) a
- | a==x = y
- | True = clookupElse d xs ys a
-#endif
-\end{code}
-
-The following routine given a curried environment replaces the entry
-labelled with a given name with a new value given. The new value is
-given in the form of a function that allows to transform the old entry.
-
-Assumption is that the list of labels contains the given one and that
-the two lists of the curried environment are of equal lengths.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-clookrepl :: Eq a => [a] -> [b] -> a -> (b -> b) -> [b]
-clookrepl (a:as) (b:bs) x f
- = if x == a then (f b:bs) else (b:clookrepl as bs x f)
-#endif
-\end{code}
-
-The following returns the index of an element in a list.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-
-elemIndex :: Eq a => [a] -> a -> Int
-elemIndex as x = indx as x 0
- where
- indx :: Eq a => [a] -> a -> Int -> Int
- indx (a:as) x n = if a==x then n else indx as x ((n+1)::Int)
-# if defined(COMPILING_GHC)
- indx [] x n = pprPanic "element not in list in elemIndex" ppNil
-# else
- indx [] x n = error "element not in list in elemIndex"
-# endif
-#endif
-\end{code}
-
%************************************************************************
%* *
\subsection[Utils-dups]{Duplicate-handling}
%* *
%************************************************************************
-List difference (non-associative). In the result of @xs \\\ ys@, the
-first occurrence of each element of ys in turn (if any) has been
-removed from xs. Thus, @(xs ++ ys) \\\ xs == ys@. This function is
-a copy of @\\@ from report 1.1 and is added to overshade the buggy
-version from the 1.0 version of Haskell.
-
-This routine can be removed after the compiler bootstraps itself and
-a proper @\\@ is can be applied.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-(\\\) :: (Eq a) => [a] -> [a] -> [a]
-(\\\) = foldl del
- where
- [] `del` _ = []
- (x:xs) `del` y
- | x == y = xs
- | otherwise = x : xs `del` y
-#endif
-\end{code}
-
\begin{code}
hasNoDups :: (Eq a) => [a] -> Bool
+
hasNoDups xs = f [] xs
where
f seen_so_far [] = True
\begin{code}
equivClasses :: (a -> a -> TAG_) -- Comparison
- -> [a]
+ -> [a]
-> [[a]]
equivClasses cmp stuff@[] = []
tells when two elements are equal.
\begin{code}
-runs :: (a -> a -> Bool) -- Equality
- -> [a]
+runs :: (a -> a -> Bool) -- Equality
+ -> [a]
-> [[a]]
runs p [] = []
qsort lt (x:xs) r = qpart lt x xs [] [] r
-- qpart partitions and sorts the sublists
--- rlt contains things less than x,
+-- rlt contains things less than x,
-- rge contains the ones greater than or equal to x.
-- Both have equal elements reversed with respect to the original list.
if lt y x then
-- y < x
qpart lt x ys (y:rlt) rge r
- else
+ else
-- y >= x
qpart lt x ys rlt (y:rge) r
To: partain@dcs.gla.ac.uk
Subject: natural merge sort beats quick sort [ and it is prettier ]
-Here a piece of Haskell code that I'm rather fond of. See it as an
+Here is a piece of Haskell code that I'm rather fond of. See it as an
attempt to get rid of the ridiculous quick-sort routine. group is
quite useful by itself I think it was John's idea originally though I
believe the lazy version is due to me [surprisingly complicated].
gamma [used to be called] is called gamma because I got inspired by
the Gamma calculus. It is not very close to the calculus but does
-behave less sequentially than both foldr and foldl. One could imagine a
-version of gamma that took a unit element as well thereby avoiding the
-problem with empty lists.
+behave less sequentially than both foldr and foldl. One could imagine
+a version of gamma that took a unit element as well thereby avoiding
+the problem with empty lists.
I've tried this code against
approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
fpca article ] isn't used because of group.
-have fun
+have fun
Carsten
\end{display}
\begin{code}
group :: (a -> a -> Bool) -> [a] -> [[a]]
+{-
+Date: Mon, 12 Feb 1996 15:09:41 +0000
+From: Andy Gill <andy@dcs.gla.ac.uk>
+
+Here is a `better' definition of group.
+-}
+group p [] = []
+group p (x:xs) = group' xs x x (x :)
+ where
+ group' [] _ _ s = [s []]
+ group' (x:xs) x_min x_max s
+ | not (x `p` x_max) = group' xs x_min x (s . (x :))
+ | x `p` x_min = group' xs x x_max ((x :) . s)
+ | otherwise = s [] : group' xs x x (x :)
+
+-- This one works forwards *and* backwards, as well as also being
+-- faster that the one in Util.lhs.
+
+{- ORIG:
group p [] = [[]]
-group p (x:xs) =
+group p (x:xs) =
let ((h1:t1):tt1) = group p xs
(t,tt) = if null xs then ([],[]) else
- if x `p` h1 then (h1:t1,tt1) else
- ([], (h1:t1):tt1)
+ if x `p` h1 then (h1:t1,tt1) else
+ ([], (h1:t1):tt1)
in ((x:t):tt)
+-}
generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
generalMerge p xs [] = xs
generalMerge p [] ys = ys
generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
- | otherwise = y : generalMerge p (x:xs) ys
+ | otherwise = y : generalMerge p (x:xs) ys
-- gamma is now called balancedFold
\begin{code}
transitiveClosure :: (a -> [a]) -- Successor function
-> (a -> a -> Bool) -- Equality predicate
- -> [a]
+ -> [a]
-> [a] -- The transitive closure
transitiveClosure succ eq xs
-- Function of elt of input list
-- and accumulator, returning new
-- accumulator and elt of result list
- -> accl -- Initial accumulator from left
- -> accr -- Initial accumulator from right
- -> [x] -- Input list
- -> (accl, accr, [y]) -- Final accumulators and result list
+ -> accl -- Initial accumulator from left
+ -> accr -- Initial accumulator from right
+ -> [x] -- Input list
+ -> (accl, accr, [y]) -- Final accumulators and result list
mapAccumB f a b [] = (a,b,[])
mapAccumB f a b (x:xs) = (a'',b'',y:ys)
See also @tagCmp_@ near the versions-compatibility section.
+The Ord3 class will be subsumed into Ord in Haskell 1.3.
+
+\begin{code}
+class Ord3 a where
+ cmp :: a -> a -> TAG_
+
+thenCmp :: TAG_ -> TAG_ -> TAG_
+{-# INLINE thenCmp #-}
+thenCmp EQ_ any = any
+thenCmp other any = other
+
+cmpList :: (a -> a -> TAG_) -> [a] -> [a] -> TAG_
+ -- `cmpList' uses a user-specified comparer
+
+cmpList cmp [] [] = EQ_
+cmpList cmp [] _ = LT_
+cmpList cmp _ [] = GT_
+cmpList cmp (a:as) (b:bs)
+ = case cmp a b of { EQ_ -> cmpList cmp as bs; xxx -> xxx }
+\end{code}
+
+\begin{code}
+instance Ord3 a => Ord3 [a] where
+ cmp [] [] = EQ_
+ cmp (x:xs) [] = GT_
+ cmp [] (y:ys) = LT_
+ cmp (x:xs) (y:ys) = (x `cmp` y) `thenCmp` (xs `cmp` ys)
+
+instance Ord3 a => Ord3 (Maybe a) where
+ cmp Nothing Nothing = EQ_
+ cmp Nothing (Just y) = LT_
+ cmp (Just x) Nothing = GT_
+ cmp (Just x) (Just y) = x `cmp` y
+
+instance Ord3 Int where
+ cmp a b | a < b = LT_
+ | a > b = GT_
+ | otherwise = EQ_
+\end{code}
+
\begin{code}
cmpString :: String -> String -> TAG_
cmpString [] ys = LT_
cmpString xs [] = GT_
-cmpString _ _ = case (panic "cmpString") of { s -> -- BUG avoidance: never get here
- cmpString s "" -- will never get here
- }
+cmpString _ _ = panic# "cmpString"
\end{code}
\begin{code}
foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
foldPair fg ab [] = ab
foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
- where (u,v) = foldPair fg ab abs
+ where (u,v) = foldPair fg ab abs
\end{code}
\begin{code}
++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" )
pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
-
pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg))
+-- #-versions because panic can't return an unboxed int, and that's
+-- what TAG_ is with GHC at the moment. Ugh. (Simon)
+-- No, man -- Too Beautiful! (Will)
+
+panic# :: String -> TAG_
+panic# s = case (panic s) of () -> EQ_
+
+pprPanic# heading pretty_msg = panic# (heading++(ppShow 80 pretty_msg))
+
# ifdef DEBUG
assertPanic :: String -> Int -> a
assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
projects / ghc-hetmet.git / commitdiff