From 7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff Mon Sep 17 00:00:00 2001 From: partain Date: Fri, 5 Apr 1996 08:30:45 +0000 Subject: [PATCH] [project @ 1996-04-05 08:26:04 by partain] Add SLPJ/WDP 1.3 changes through 960404 --- ghc/compiler/Jmakefile | 153 +- ghc/compiler/absCSyn/AbsCLoop.lhi | 50 + ghc/compiler/absCSyn/AbsCSyn.lhs | 83 +- ghc/compiler/absCSyn/AbsCUtils.lhs | 63 +- ghc/compiler/absCSyn/CLabel.lhs | 48 +- ghc/compiler/absCSyn/Costs.lhs | 9 +- ghc/compiler/absCSyn/HeapOffs.lhs | 55 +- ghc/compiler/absCSyn/PprAbsC.lhs | 106 +- ghc/compiler/basicTypes/FieldLabel.lhs | 45 + ghc/compiler/basicTypes/Id.lhs | 314 +-- ghc/compiler/basicTypes/IdInfo.lhs | 8 +- ghc/compiler/basicTypes/IdLoop.lhi | 8 +- ghc/compiler/basicTypes/Name.lhs | 4 +- ghc/compiler/basicTypes/PprEnv.lhs | 121 ++ ghc/compiler/basicTypes/UniqSupply.lhs | 19 + ghc/compiler/codeGen/CgBindery.lhs | 60 +- ghc/compiler/codeGen/CgCase.lhs | 166 +- ghc/compiler/codeGen/CgClosure.lhs | 133 +- ghc/compiler/codeGen/CgCompInfo.lhs | 3 + ghc/compiler/codeGen/CgCon.lhs | 92 +- ghc/compiler/codeGen/CgConTbls.lhs | 125 +- ghc/compiler/codeGen/CgExpr.lhs | 67 +- ghc/compiler/codeGen/CgHeapery.lhs | 31 +- ghc/compiler/codeGen/CgLetNoEscape.lhs | 21 +- ghc/compiler/codeGen/CgLoop1.lhi | 35 + ghc/compiler/codeGen/CgLoop2.lhi | 15 + ghc/compiler/codeGen/CgMonad.lhs | 168 +- ghc/compiler/codeGen/CgRetConv.lhs | 136 +- ghc/compiler/codeGen/CgStackery.lhs | 17 +- ghc/compiler/codeGen/CgTailCall.lhs | 67 +- ghc/compiler/codeGen/CgUpdate.lhs | 20 +- ghc/compiler/codeGen/CgUsages.lhs | 17 +- ghc/compiler/codeGen/ClosureInfo.lhs | 170 +- ghc/compiler/codeGen/CodeGen.lhs | 37 +- ghc/compiler/codeGen/SMRep.lhs | 24 +- ghc/compiler/coreSyn/CoreLift.lhs | 3 +- ghc/compiler/coreSyn/CoreLint.lhs | 47 +- ghc/compiler/coreSyn/CoreSyn.lhs | 123 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 23 +- ghc/compiler/coreSyn/CoreUtils.lhs | 150 +- ghc/compiler/coreSyn/FreeVars.lhs | 14 +- ghc/compiler/coreSyn/PprCore.lhs | 226 +-- ghc/compiler/deSugar/Desugar.lhs | 25 +- ghc/compiler/deSugar/DsBinds.lhs | 53 +- ghc/compiler/deSugar/DsCCall.lhs | 9 +- ghc/compiler/deSugar/DsExpr.lhs | 51 +- ghc/compiler/deSugar/DsGRHSs.lhs | 7 +- ghc/compiler/deSugar/DsMonad.lhs | 13 +- ghc/compiler/deSugar/DsUtils.lhs | 10 +- ghc/compiler/deSugar/Match.lhs | 39 +- ghc/compiler/deSugar/MatchLit.lhs | 2 +- ghc/compiler/deforest/Core2Def.lhs | 8 +- ghc/compiler/deforest/Cyclic.lhs | 3 +- ghc/compiler/hsSyn/HsBinds.lhs | 3 +- ghc/compiler/hsSyn/HsDecls.lhs | 2 +- ghc/compiler/hsSyn/HsExpr.lhs | 39 +- ghc/compiler/hsSyn/HsMatches.lhs | 2 - ghc/compiler/hsSyn/HsPat.lhs | 26 +- ghc/compiler/main/ErrUtils.lhs | 35 +- ghc/compiler/main/Main.lhs | 90 +- ghc/compiler/main/MkIface.lhs | 6 +- ghc/compiler/nativeGen/AbsCStixGen.lhs | 226 +-- ghc/compiler/nativeGen/AlphaCode.lhs | 1402 ------------- ghc/compiler/nativeGen/AlphaDesc.lhs | 208 -- ghc/compiler/nativeGen/AlphaGen.lhs | 1107 ----------- ghc/compiler/nativeGen/AsmCodeGen.lhs | 447 ++--- ghc/compiler/nativeGen/AsmRegAlloc.lhs | 390 +--- ghc/compiler/nativeGen/I386Code.lhs | 1365 ------------- ghc/compiler/nativeGen/I386Desc.lhs | 198 -- ghc/compiler/nativeGen/I386Gen.lhs | 1639 ---------------- ghc/compiler/nativeGen/MachCode.lhs | 3248 +++++++++++++++++++++++++++++++ ghc/compiler/nativeGen/MachDesc.lhs | 95 - ghc/compiler/nativeGen/MachMisc.lhs | 676 +++++++ ghc/compiler/nativeGen/MachRegs.lhs | 1022 ++++++++++ ghc/compiler/nativeGen/NCG.h | 150 ++ ghc/compiler/nativeGen/NcgLoop.lhi | 16 + ghc/compiler/nativeGen/PprMach.lhs | 1323 +++++++++++++ ghc/compiler/nativeGen/RegAllocInfo.lhs | 799 ++++++++ ghc/compiler/nativeGen/SparcCode.lhs | 1389 ------------- ghc/compiler/nativeGen/SparcDesc.lhs | 197 -- ghc/compiler/nativeGen/SparcGen.lhs | 1289 ------------ ghc/compiler/nativeGen/Stix.lhs | 172 +- ghc/compiler/nativeGen/StixInfo.lhs | 52 +- ghc/compiler/nativeGen/StixInteger.lhs | 431 ++-- ghc/compiler/nativeGen/StixMacro.lhs | 254 +-- ghc/compiler/nativeGen/StixPrim.lhs | 627 +++--- ghc/compiler/parser/UgenAll.lhs | 2 - ghc/compiler/parser/hslexer.flex | 4 +- ghc/compiler/parser/hsparser.y | 1 + ghc/compiler/prelude/PrelInfo.lhs | 4 +- ghc/compiler/prelude/PrelVals.lhs | 11 +- ghc/compiler/prelude/PrimOp.lhs | 80 +- ghc/compiler/prelude/TysPrim.lhs | 4 +- ghc/compiler/prelude/TysWiredIn.lhs | 5 +- ghc/compiler/profiling/SCCfinal.lhs | 46 +- ghc/compiler/reader/ReadPrefix.lhs | 29 +- ghc/compiler/rename/RnBinds4.lhs | 10 +- ghc/compiler/rename/RnExpr4.lhs | 6 +- ghc/compiler/rename/RnHsSyn.lhs | 1 + ghc/compiler/rename/RnPass1.lhs | 2 +- ghc/compiler/rename/RnPass4.lhs | 7 +- ghc/compiler/simplCore/AnalFBWW.lhs | 52 +- ghc/compiler/simplCore/FloatIn.lhs | 11 +- ghc/compiler/simplCore/FoldrBuildWW.lhs | 57 +- ghc/compiler/simplCore/MagicUFs.lhs | 25 +- ghc/compiler/simplCore/OccurAnal.lhs | 146 +- ghc/compiler/simplCore/SimplCase.lhs | 150 +- ghc/compiler/simplCore/SimplCore.lhs | 151 +- ghc/compiler/simplCore/SimplEnv.lhs | 15 +- ghc/compiler/simplCore/SimplMonad.lhs | 6 +- ghc/compiler/simplCore/SimplPgm.lhs | 81 +- ghc/compiler/simplCore/SimplUtils.lhs | 46 +- ghc/compiler/simplCore/SimplVar.lhs | 64 +- ghc/compiler/simplCore/Simplify.lhs | 222 +-- ghc/compiler/simplCore/SmplLoop.lhi | 18 +- ghc/compiler/simplStg/LambdaLift.lhs | 55 +- ghc/compiler/simplStg/SatStgRhs.lhs | 28 +- ghc/compiler/simplStg/SimplStg.lhs | 63 +- ghc/compiler/simplStg/StgSAT.lhs | 16 +- ghc/compiler/simplStg/StgSATMonad.lhs | 31 +- ghc/compiler/simplStg/StgStats.lhs | 12 +- ghc/compiler/simplStg/StgVarInfo.lhs | 109 +- ghc/compiler/simplStg/UpdAnal.lhs | 34 +- ghc/compiler/specialise/SpecEnv.lhs | 7 +- ghc/compiler/specialise/SpecUtils.lhs | 86 +- ghc/compiler/specialise/Specialise.lhs | 482 +++-- ghc/compiler/stgSyn/CoreToStg.lhs | 128 +- ghc/compiler/stgSyn/StgLint.lhs | 95 +- ghc/compiler/stgSyn/StgSyn.lhs | 37 +- ghc/compiler/stgSyn/StgUtils.lhs | 24 +- ghc/compiler/stranal/SaAbsInt.lhs | 80 +- ghc/compiler/stranal/SaLib.lhs | 18 +- ghc/compiler/stranal/StrictAnal.lhs | 64 +- ghc/compiler/stranal/WorkWrap.lhs | 128 +- ghc/compiler/stranal/WwLib.lhs | 99 +- ghc/compiler/typecheck/GenSpecEtc.lhs | 70 +- ghc/compiler/typecheck/Inst.lhs | 5 +- ghc/compiler/typecheck/TcBinds.lhs | 22 +- ghc/compiler/typecheck/TcClassDcl.lhs | 42 +- ghc/compiler/typecheck/TcDeriv.lhs | 16 +- ghc/compiler/typecheck/TcEnv.lhs | 54 +- ghc/compiler/typecheck/TcExpr.lhs | 278 ++- ghc/compiler/typecheck/TcGenDeriv.lhs | 60 +- ghc/compiler/typecheck/TcHsSyn.lhs | 24 +- ghc/compiler/typecheck/TcInstDcls.lhs | 73 +- ghc/compiler/typecheck/TcKind.lhs | 29 +- ghc/compiler/typecheck/TcMatches.lhs | 2 +- ghc/compiler/typecheck/TcModule.lhs | 20 +- ghc/compiler/typecheck/TcMonad.lhs | 48 +- ghc/compiler/typecheck/TcMonoType.lhs | 62 +- ghc/compiler/typecheck/TcPat.lhs | 98 +- ghc/compiler/typecheck/TcPragmas.lhs | 2 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 69 +- ghc/compiler/typecheck/TcTyDecls.lhs | 227 ++- ghc/compiler/typecheck/TcType.lhs | 79 +- ghc/compiler/typecheck/Typecheck.lhs | 4 +- ghc/compiler/typecheck/Unify.lhs | 239 ++- ghc/compiler/types/Kind.lhs | 17 + ghc/compiler/types/PprType.lhs | 80 +- ghc/compiler/types/TyCon.lhs | 173 +- ghc/compiler/types/TyLoop.lhi | 4 +- ghc/compiler/types/TyVar.lhs | 10 +- ghc/compiler/types/Type.lhs | 102 +- ghc/compiler/utils/BitSet.lhs | 40 +- ghc/compiler/utils/CharSeq.lhs | 4 +- ghc/compiler/utils/FiniteMap.lhs | 10 +- ghc/compiler/utils/MatchEnv.lhs | 8 +- ghc/compiler/utils/PprStyle.lhs | 10 +- ghc/compiler/utils/Pretty.lhs | 2 +- ghc/compiler/utils/Ubiq.lhi | 15 + ghc/compiler/utils/UniqFM.lhs | 14 +- ghc/compiler/utils/UniqSet.lhs | 12 +- ghc/compiler/utils/Unpretty.lhs | 9 +- ghc/compiler/utils/Util.lhs | 3 +- 174 files changed, 12961 insertions(+), 14148 deletions(-) create mode 100644 ghc/compiler/absCSyn/AbsCLoop.lhi create mode 100644 ghc/compiler/basicTypes/FieldLabel.lhs create mode 100644 ghc/compiler/basicTypes/PprEnv.lhs create mode 100644 ghc/compiler/codeGen/CgLoop1.lhi create mode 100644 ghc/compiler/codeGen/CgLoop2.lhi delete mode 100644 ghc/compiler/nativeGen/AlphaCode.lhs delete mode 100644 ghc/compiler/nativeGen/AlphaDesc.lhs delete mode 100644 ghc/compiler/nativeGen/AlphaGen.lhs delete mode 100644 ghc/compiler/nativeGen/I386Code.lhs delete mode 100644 ghc/compiler/nativeGen/I386Desc.lhs delete mode 100644 ghc/compiler/nativeGen/I386Gen.lhs create mode 100644 ghc/compiler/nativeGen/MachCode.lhs delete mode 100644 ghc/compiler/nativeGen/MachDesc.lhs create mode 100644 ghc/compiler/nativeGen/MachMisc.lhs create mode 100644 ghc/compiler/nativeGen/MachRegs.lhs create mode 100644 ghc/compiler/nativeGen/NCG.h create mode 100644 ghc/compiler/nativeGen/NcgLoop.lhi create mode 100644 ghc/compiler/nativeGen/PprMach.lhs create mode 100644 ghc/compiler/nativeGen/RegAllocInfo.lhs delete mode 100644 ghc/compiler/nativeGen/SparcCode.lhs delete mode 100644 ghc/compiler/nativeGen/SparcDesc.lhs delete mode 100644 ghc/compiler/nativeGen/SparcGen.lhs diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile index aecfcbd..55a455e 100644 --- a/ghc/compiler/Jmakefile +++ b/ghc/compiler/Jmakefile @@ -95,17 +95,19 @@ 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/FieldLabel.lhs \ basicTypes/Id.lhs \ basicTypes/IdInfo.lhs \ basicTypes/IdUtils.lhs \ -basicTypes/PragmaInfo.lhs \ basicTypes/Literal.lhs \ +basicTypes/Name.lhs \ +basicTypes/NameTypes.lhs \ +basicTypes/PprEnv.lhs \ +basicTypes/PragmaInfo.lhs \ +basicTypes/ProtoName.lhs \ +basicTypes/SrcLoc.lhs \ +basicTypes/UniqSupply.lhs \ +basicTypes/Unique.lhs \ \ types/Class.lhs \ types/Kind.lhs \ @@ -181,6 +183,22 @@ deSugar/DsUtils.lhs \ coreSyn/CoreLift.lhs \ coreSyn/CoreLint.lhs +#if GhcWithDeforester != YES +#define __omit_deforester_flag -DOMIT_DEFORESTER=1 +#define DEFORESTER_SRCS_LHS /*none*/ +#else +#define __omit_deforester_flag /*nope*/ +#define DEFORESTER_SRCS_LHS \ +deforest/DefSyn.lhs \ +deforest/Core2Def.lhs \ +deforest/Def2Core.lhs \ +deforest/Deforest.lhs \ +deforest/DefUtils.lhs \ +deforest/DefExpr.lhs \ +deforest/Cyclic.lhs \ +deforest/TreelessForm.lhs +#endif /* GhcWithDeforester */ + #define SIMPL_SRCS_LHS \ coreSyn/AnnCoreSyn.lhs \ coreSyn/FreeVars.lhs \ @@ -215,30 +233,14 @@ stranal/SaAbsInt.lhs \ stranal/WwLib.lhs \ stranal/WorkWrap.lhs \ \ -profiling/SCCauto.lhs \ -profiling/SCCfinal.lhs +profiling/SCCauto.lhs DEFORESTER_SRCS_LHS -#if GhcWithDeforester != YES -#define __omit_deforester_flag -DOMIT_DEFORESTER=1 -#define DEFORESTER_SRCS_LHS /*none*/ -#else -#define __omit_deforester_flag /*nope*/ -#define DEFORESTER_SRCS_LHS \ -deforest/DefSyn.lhs \ -deforest/Core2Def.lhs \ -deforest/Def2Core.lhs \ -deforest/Deforest.lhs \ -deforest/DefUtils.lhs \ -deforest/DefExpr.lhs \ -deforest/Cyclic.lhs \ -deforest/TreelessForm.lhs -#endif /* GhcWithDeforester */ - -#define BACKSRCS_LHS \ +#define STG_SRCS_LHS \ stgSyn/CoreToStg.lhs \ stgSyn/StgSyn.lhs \ stgSyn/StgUtils.lhs \ stgSyn/StgLint.lhs \ +profiling/SCCfinal.lhs \ \ simplStg/SatStgRhs.lhs \ simplStg/LambdaLift.lhs \ @@ -247,8 +249,9 @@ simplStg/UpdAnal.lhs \ simplStg/StgStats.lhs \ simplStg/StgSATMonad.lhs \ simplStg/StgSAT.lhs \ -simplStg/SimplStg.lhs \ -\ +simplStg/SimplStg.lhs + +#define BACKSRCS_LHS \ absCSyn/AbsCUtils.lhs \ absCSyn/AbsCSyn.lhs \ absCSyn/CLabel.lhs \ @@ -283,36 +286,21 @@ codeGen/CgUpdate.lhs # define NATIVEGEN_SRCS_LHS /*none*/ #else # define __omit_ncg_maybe /*none*/ -# if i386_TARGET_ARCH -# define __machdep_nativegen_lhs \ -nativeGen/I386Desc.lhs \ -nativeGen/I386Code.lhs \ -nativeGen/I386Gen.lhs -# endif -# if sparc_TARGET_ARCH -# define __machdep_nativegen_lhs \ -nativeGen/SparcDesc.lhs \ -nativeGen/SparcCode.lhs \ -nativeGen/SparcGen.lhs -# endif -# if alpha_TARGET_ARCH -# define __machdep_nativegen_lhs \ -nativeGen/AlphaDesc.lhs \ -nativeGen/AlphaCode.lhs \ -nativeGen/AlphaGen.lhs -# endif # define NATIVEGEN_SRCS_LHS \ nativeGen/AbsCStixGen.lhs \ nativeGen/AsmCodeGen.lhs \ nativeGen/AsmRegAlloc.lhs \ -nativeGen/MachDesc.lhs \ +nativeGen/MachCode.lhs \ +nativeGen/MachMisc.lhs \ +nativeGen/MachRegs.lhs \ +nativeGen/PprMach.lhs \ +nativeGen/RegAllocInfo.lhs \ nativeGen/Stix.lhs \ nativeGen/StixInfo.lhs \ nativeGen/StixInteger.lhs \ nativeGen/StixPrim.lhs \ -nativeGen/StixMacro.lhs \ -__machdep_nativegen_lhs /*arch-specific ones */ +nativeGen/StixMacro.lhs #endif #define UTILSRCS_LHS \ @@ -366,22 +354,20 @@ simplCore/MagicUFs.lhs ALLSRCS_HS = READERSRCS_HS ALLSRCS_LHS = /* all pieces of the compiler */ \ -VBASICSRCS_LHS \ -NOT_SO_BASICSRCS_LHS \ -UTILSRCS_LHS \ -MAIN_SRCS_LHS \ -READERSRCS_LHS \ -RENAMERSRCS_LHS \ -TCSRCS_LHS \ -DSSRCS_LHS +VBASICSRCS_LHS \ +NOT_SO_BASICSRCS_LHS \ +UTILSRCS_LHS \ +MAIN_SRCS_LHS \ +READERSRCS_LHS \ +RENAMERSRCS_LHS \ +TCSRCS_LHS \ +DSSRCS_LHS \ +SIMPL_SRCS_LHS \ +STG_SRCS_LHS \ +BACKSRCS_LHS NATIVEGEN_SRCS_LHS /* -SIMPL_SRCS_LHS -BACKSRCS_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. */ @@ -405,13 +391,6 @@ ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi) #define __version_sensitive_flags -fomit-reexported-instances #endif -#if GhcWithRegisterised == NO - /* doing a raw boot from .hc files, presumably */ -#define __unreg_opts_maybe -O -unregisterised -#else -#define __unreg_opts_maybe /*none*/ -#endif - /* avoid use of AllProjectsHcOpts; then put in HcMaxHeapFlag "by hand" */ #undef AllProjectsHcOpts #define AllProjectsHcOpts /**/ @@ -419,10 +398,9 @@ ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi) 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 + use_DDEBUG __version_sensitive_flags __omit_ncg_maybe __omit_deforester_flag #undef __version_sensitive_flags -#undef __unreg_opts_maybe #undef __omit_ncg_maybe #undef __omit_deforester_flag @@ -505,14 +483,22 @@ HaskellCompileWithExtraFlags_Recursive(module,isuf,o,-c,extra_flags) utils/Ubiq.hi : utils/Ubiq.lhi $(GHC_UNLIT) utils/Ubiq.lhi utils/Ubiq.hi +absCSyn/AbsCLoop.hi : absCSyn/AbsCLoop.lhi + $(GHC_UNLIT) absCSyn/AbsCLoop.lhi absCSyn/AbsCLoop.hi basicTypes/IdLoop.hi : basicTypes/IdLoop.lhi $(GHC_UNLIT) basicTypes/IdLoop.lhi basicTypes/IdLoop.hi basicTypes/NameLoop.hi : basicTypes/NameLoop.lhi $(GHC_UNLIT) basicTypes/NameLoop.lhi basicTypes/NameLoop.hi +codeGen/CgLoop1.hi : codeGen/CgLoop1.lhi + $(GHC_UNLIT) codeGen/CgLoop1.lhi codeGen/CgLoop1.hi +codeGen/CgLoop2.hi : codeGen/CgLoop2.lhi + $(GHC_UNLIT) codeGen/CgLoop2.lhi codeGen/CgLoop2.hi deSugar/DsLoop.hi : deSugar/DsLoop.lhi $(GHC_UNLIT) deSugar/DsLoop.lhi deSugar/DsLoop.hi hsSyn/HsLoop.hi : hsSyn/HsLoop.lhi $(GHC_UNLIT) hsSyn/HsLoop.lhi hsSyn/HsLoop.hi +nativeGen/NcgLoop.hi : nativeGen/NcgLoop.lhi + $(GHC_UNLIT) nativeGen/NcgLoop.lhi nativeGen/NcgLoop.hi prelude/PrelLoop.hi : prelude/PrelLoop.lhi $(GHC_UNLIT) prelude/PrelLoop.lhi prelude/PrelLoop.hi reader/RdrLoop.hi : reader/RdrLoop.lhi @@ -548,12 +534,14 @@ compile(hsSyn/HsPragmas,lhs,) compile(hsSyn/HsTypes,lhs,) compile(hsSyn/HsSyn,lhs,if_ghc(-fno-omit-reexported-instances)) +compile(basicTypes/FieldLabel,lhs,) 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/PprEnv,lhs,) compile(basicTypes/PragmaInfo,lhs,) compile(basicTypes/ProtoName,lhs,) compile(basicTypes/SrcLoc,lhs,) @@ -611,27 +599,16 @@ compile(main/MkIface,lhs,) compile(nativeGen/AbsCStixGen,lhs,) compile(nativeGen/AsmCodeGen,lhs,-I$(COMPINFO_DIR)) compile(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR)) -compile(nativeGen/MachDesc,lhs,) +compile(nativeGen/MachCode,lhs,) +compile(nativeGen/MachMisc,lhs,) +compile(nativeGen/MachRegs,lhs,) +compile(nativeGen/PprMach,lhs,) +compile(nativeGen/RegAllocInfo,lhs,) compile(nativeGen/Stix,lhs,) compile(nativeGen/StixInfo,lhs,-I$(NATIVEGEN_DIR)) compile(nativeGen/StixInteger,lhs,) compile(nativeGen/StixMacro,lhs,-I$(NATIVEGEN_DIR)) compile(nativeGen/StixPrim,lhs,) -# if i386_TARGET_ARCH -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(nativeGen/SparcDesc,lhs,) -compile(nativeGen/SparcCode,lhs,-I$(NATIVEGEN_DIR)) -compile(nativeGen/SparcGen,lhs,) -# endif -# if alpha_TARGET_ARCH -compile(nativeGen/AlphaDesc,lhs,) -compile(nativeGen/AlphaCode,lhs,-I$(NATIVEGEN_DIR)) -compile(nativeGen/AlphaGen,lhs,) -# endif #endif compile(prelude/PrelInfo,lhs,) @@ -923,7 +900,7 @@ compile(parser/U_ttype,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"') /* *** misc *************************************************** */ -DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS) SIMPL_SRCS_LHS +DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS) #if GhcWithHscBuiltViaC == NO MKDEPENDHS_OPTS= -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h diff --git a/ghc/compiler/absCSyn/AbsCLoop.lhi b/ghc/compiler/absCSyn/AbsCLoop.lhi new file mode 100644 index 0000000..2d5f61d --- /dev/null +++ b/ghc/compiler/absCSyn/AbsCLoop.lhi @@ -0,0 +1,50 @@ +Breaks the loop caused by PprAbsC needing to +see big swathes of ClosureInfo. + +Also from CLabel needing a couple of CgRetConv things. + +Also from HeapOffs needing some MachMisc things. + +\begin{code} +interface AbsCLoop where +import PreludeStdIO ( Maybe ) + +import CgRetConv ( ctrlReturnConvAlg, + CtrlReturnConvention(..) + ) +import ClosureInfo ( closureKind, closureLabelFromCI, + closureNonHdrSize, closurePtrsSize, + closureSMRep, closureSemiTag, + closureSizeWithoutFixedHdr, + closureTypeDescr, closureUpdReqd, + infoTableLabelFromCI, maybeSelectorInfo, + entryLabelFromCI,fastLabelFromCI, + ClosureInfo + ) +import CLabel ( CLabel ) +import HeapOffs ( HeapOffset ) +import Id ( Id(..) ) +import MachMisc ( fixedHdrSizeInWords, varHdrSizeInWords ) +import SMRep ( SMRep ) +import TyCon ( TyCon ) + +closureKind :: ClosureInfo -> [Char] +closureLabelFromCI :: ClosureInfo -> CLabel +closureNonHdrSize :: ClosureInfo -> Int +closurePtrsSize :: ClosureInfo -> Int +closureSMRep :: ClosureInfo -> SMRep +closureSemiTag :: ClosureInfo -> Int +closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset +closureTypeDescr :: ClosureInfo -> [Char] +closureUpdReqd :: ClosureInfo -> Bool +entryLabelFromCI :: ClosureInfo -> CLabel +fastLabelFromCI :: ClosureInfo -> CLabel +infoTableLabelFromCI :: ClosureInfo -> CLabel +maybeSelectorInfo :: ClosureInfo -> Maybe (Id, Int) + +ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention +data CtrlReturnConvention = VectoredReturn Int | UnvectoredReturn Int + +fixedHdrSizeInWords :: Int +varHdrSizeInWords :: SMRep -> Int +\end{code} diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index f23614d..c36e26e 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -14,7 +14,7 @@ raw assembler/machine code. \begin{code} #include "HsVersions.h" -module AbsCSyn ( +module AbsCSyn {- ( -- export everything AbstractC(..), CStmtMacro(..), @@ -26,68 +26,37 @@ module AbsCSyn ( mkAbsCStmtList, mkCCostCentre, - -- HeapOffsets, plus some convenient synonyms... - HeapOffset, - zeroOff, intOff, fixedHdrSize, totHdrSize, varHdrSize, - maxOff, addOff, subOff, intOffsetIntoGoods, - isZeroOff, possiblyEqualHeapOffset, - pprHeapOffset, - VirtualHeapOffset(..), HpRelOffset(..), - VirtualSpAOffset(..), VirtualSpBOffset(..), - SpARelOffset(..), SpBRelOffset(..), - -- RegRelatives RegRelative(..), -- registers MagicId(..), node, infoptr, - isVolatileReg, - - -- closure info - ClosureInfo, LambdaFormInfo, UpdateFlag, SMRep, - - -- stuff from AbsCUtils and PprAbsC... - nonemptyAbsC, flattenAbsC, getAmodeRep, - mixedTypeLocn, mixedPtrLocn, - writeRealC, - dumpRealC, - kindFromMagicId, - amodeCanSurviveGC + isVolatileReg, noLiveRegsMask, mkLiveRegsMask #ifdef GRAN , CostRes(Cost) #endif + )-} where - -- and stuff to make the interface self-sufficient - ) where - -import AbsCUtils -- used, and re-exported -import ClosureInfo -- ditto -import Costs -import PprAbsC -- ditto -import HeapOffs hiding ( hpRelToInt ) +import Ubiq{-uitous-} -import PrelInfo ( PrimOp - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG, + mAX_Double_REG, lIVENESS_R1, lIVENESS_R2, + lIVENESS_R3, lIVENESS_R4, lIVENESS_R5, + lIVENESS_R6, lIVENESS_R7, lIVENESS_R8 ) -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 PrimRep ( PrimRep(..) ) -import StgSyn ( GenStgExpr, GenStgArg, StgBinderInfo ) -import UniqSet ( UniqSet(..), UniqFM ) -import Unpretty -- ********** NOTE ********** -import Util +import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..), + VirtualHeapOffset(..) + ) +import Literal ( mkMachInt ) +import PrimRep ( isFollowableRep, PrimRep(..) ) \end{code} @AbstractC@ is a list of Abstract~C statements, but the data structure is tree-ish, for easier and more efficient putting-together. \begin{code} +absCNop = AbsCNop + data AbstractC = AbsCNop | AbsCStmts AbstractC AbstractC @@ -436,7 +405,6 @@ data ReturnInfo = DirectReturn -- Jump directly, if possible | StaticVectoredReturn Int -- Fixed tag, starting at zero | DynamicVectoredReturn CAddrMode -- Dynamic tag given by amode, starting at zero - \end{code} %************************************************************************ @@ -512,6 +480,27 @@ data MagicId node = VanillaReg PtrRep ILIT(1) -- A convenient alias for Node infoptr = VanillaReg DataPtrRep ILIT(2) -- An alias for InfoPtr + +-------------------- +noLiveRegsMask :: Int -- Mask indicating nothing live +noLiveRegsMask = 0 + +mkLiveRegsMask + :: [MagicId] -- Candidate live regs; depends what they have in them + -> Int + +mkLiveRegsMask regs + = foldl do_reg noLiveRegsMask regs + where + do_reg acc (VanillaReg kind reg_no) + | isFollowableRep kind + = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1))) + + do_reg acc anything_else = acc + + reg_tbl -- ToDo: mk Array! + = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4, + lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8] \end{code} We need magical @Eq@ because @VanillaReg@s come in multiple flavors. diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index a9789c8..e25ce5d 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -10,31 +10,28 @@ module AbsCUtils ( nonemptyAbsC, mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, - kindFromMagicId, + magicIdPrimRep, getAmodeRep, amodeCanSurviveGC, mixedTypeLocn, mixedPtrLocn, flattenAbsC, mkAbsCStmtList -- printing/forcing stuff comes from PprAbsC - - -- and for interface self-sufficiency... ) where +import Ubiq{-uitous-} + import AbsCSyn -import PrelInfo ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import Literal ( literalPrimRep ) -import CLabel ( CLabel, mkReturnPtLabel, mkVecTblLabel ) +import CLabel ( mkReturnPtLabel ) import Digraph ( stronglyConnComp ) -import Id ( fIRST_TAG, ConTag(..), DataCon(..), Id ) -import Maybes ( Maybe(..) ) -import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) ) -import UniqSupply -import StgSyn ( GenStgArg ) +import HeapOffs ( possiblyEqualHeapOffset ) +import Id ( fIRST_TAG, ConTag(..) ) +import Literal ( literalPrimRep, Literal(..) ) +import PrimRep ( getPrimRepSize, PrimRep(..) ) +import Unique ( Unique{-instance Eq-} ) +import UniqSupply ( getUnique, getUniques, splitUniqSupply ) +import Util ( panic ) infixr 9 `thenFlt` \end{code} @@ -148,24 +145,24 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc %************************************************************************ \begin{code} -kindFromMagicId BaseReg = PtrRep -kindFromMagicId StkOReg = PtrRep -kindFromMagicId (VanillaReg kind _) = kind -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 +magicIdPrimRep BaseReg = PtrRep +magicIdPrimRep StkOReg = PtrRep +magicIdPrimRep (VanillaReg kind _) = kind +magicIdPrimRep (FloatReg _) = FloatRep +magicIdPrimRep (DoubleReg _) = DoubleRep +magicIdPrimRep TagReg = IntRep +magicIdPrimRep RetReg = RetRep +magicIdPrimRep SpA = PtrRep +magicIdPrimRep SuA = PtrRep +magicIdPrimRep SpB = PtrRep +magicIdPrimRep SuB = PtrRep +magicIdPrimRep Hp = PtrRep +magicIdPrimRep HpLim = PtrRep +magicIdPrimRep LivenessReg = IntRep +magicIdPrimRep StdUpdRetVecReg = PtrRep +magicIdPrimRep StkStubReg = PtrRep +magicIdPrimRep CurCostCentre = CostCentreRep +magicIdPrimRep VoidReg = VoidRep \end{code} %************************************************************************ @@ -183,7 +180,7 @@ getAmodeRep :: CAddrMode -> PrimRep getAmodeRep (CVal _ kind) = kind getAmodeRep (CAddr _) = PtrRep -getAmodeRep (CReg magic_id) = kindFromMagicId magic_id +getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id getAmodeRep (CTemp uniq kind) = kind getAmodeRep (CLbl label kind) = kind getAmodeRep (CUnVecLbl _ _) = PtrRep diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 2ecbd17..a6df009 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -39,40 +39,35 @@ module CLabel ( needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel, - pprCLabel + pprCLabel, pprCLabel_asm #ifdef GRAN , isSlowEntryCCodeBlock #endif - - -- and to make the interface self-sufficient... ) where import Ubiq{-uitous-} +import AbsCLoop ( CtrlReturnConvention(..), + ctrlReturnConvAlg + ) +import NcgLoop ( underscorePrefix, fmtAsmLbl ) +import CStrings ( pp_cSEP ) import Id ( externallyVisibleId, cmpId_withSpecDataCon, isDataCon, isDictFunId, - isConstMethodId_maybe, isClassOpId, + isConstMethodId_maybe, isDefaultMethodId_maybe, isSuperDictSelId_maybe, fIRST_TAG, - DataCon(..), ConTag(..), Id + ConTag(..), GenId{-instance Outputable-} ) import Maybes ( maybeToBool ) +import PprStyle ( PprStyle(..) ) +import PprType ( showTyCon, GenType{-instance Outputable-} ) +import Pretty ( prettyToUn ) +import TyCon ( TyCon{-instance Eq-} ) +import Unique ( showUnique, pprUnique, Unique{-instance Eq-} ) 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 Unique ( pprUnique, showUnique, Unique ) -import Util - --- Sigh... Shouldn't this file (CLabel) live in codeGen? -import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg ) --} +import Util ( assertPanic ) \end{code} things we want to find out: @@ -290,14 +285,13 @@ externallyVisibleCLabel (IdLabel (CLabelId id) _) | isDataCon id = True | is_ConstMethodId id = True -- These are here to ensure splitting works | isDictFunId id = True -- when these values have not been exported - | isClassOpId id = True | is_DefaultMethodId id = True | is_SuperDictSelId id = True | otherwise = externallyVisibleId id where - is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id) + is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id) is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id) - is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id) + is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id) \end{code} These GRAN functions are needed for spitting out GRAN_FETCH() at the @@ -319,17 +313,20 @@ duplicate declarations in generating C (see @labelSeenTE@ in @PprAbsC@). \begin{code} +-- specialised for PprAsm: saves lots of arg passing in NCG +pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) + 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 +pprCLabel (PprForAsm prepend_cSEP _) lbl = if prepend_cSEP then uppBeside pp_cSEP prLbl else prLbl where - prLbl = pprCLabel (PprForC sw_chker) lbl + prLbl = pprCLabel PprForC lbl pprCLabel sty (TyConLabel tc UnvecConUpdCode) = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), @@ -399,4 +396,3 @@ ppFlavor x = uppBeside pp_cSEP RednCounts -> uppPStr SLIT("ct") ) \end{code} - diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 7a2d9dc..fd803f6 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1994-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1994-1996 % Hans Wolfgang Loidl % % --------------------------------------------------------------------------- @@ -57,12 +57,9 @@ module Costs( costs, addrModeCosts, CostRes(Cost), nullCosts, Side(..) ) where -import AbsCUtils +import Ubiq{-uitous-} + import AbsCSyn -import PrelInfo -import PrimOp -import TyCon -import Util -- -------------------------------------------------------------------------- #ifndef GRAN diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs index d27645e..e37b4b2 100644 --- a/ghc/compiler/absCSyn/HeapOffs.lhs +++ b/ghc/compiler/absCSyn/HeapOffs.lhs @@ -22,11 +22,9 @@ module HeapOffs ( intOffsetIntoGoods, -#if 0 #if ! OMIT_NATIVE_CODEGEN hpRelToInt, #endif -#endif VirtualHeapOffset(..), HpRelOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..), @@ -34,15 +32,14 @@ module HeapOffs ( ) where import Ubiq{-uitous-} +#if ! OMIT_NATIVE_CODEGEN +import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords ) +#endif -import ClosureInfo ( isSpecRep ) import Maybes ( catMaybes ) import SMRep import Unpretty -- ********** NOTE ********** import Util ( panic ) -#if ! OMIT_NATIVE_CODEGEN ---import MachDesc ( Target ) -#endif \end{code} %************************************************************************ @@ -272,15 +269,15 @@ pprHeapOffset :: PprStyle -> HeapOffset -> Unpretty pprHeapOffset sty ZeroHeapOffset = uppChar '0' pprHeapOffset sty (MaxHeapOffset off1 off2) - = uppBesides [uppPStr SLIT("STG_MAX"), uppLparen, - pprHeapOffset sty off1, uppComma, pprHeapOffset sty off2, - uppRparen] + = uppBeside (uppPStr SLIT("STG_MAX")) + (uppParens (uppBesides [pprHeapOffset sty off1, uppComma, pprHeapOffset sty off2])) + pprHeapOffset sty (AddHeapOffset off1 off2) - = uppBesides [uppLparen, pprHeapOffset sty off1, uppChar '+', - pprHeapOffset sty off2, uppRparen] + = uppParens (uppBesides [pprHeapOffset sty off1, uppChar '+', + pprHeapOffset sty off2]) pprHeapOffset sty (SubHeapOffset off1 off2) - = uppBesides [uppLparen, pprHeapOffset sty off1, uppChar '-', - pprHeapOffset sty off2, uppRparen] + = uppParens (uppBesides [pprHeapOffset sty off1, uppChar '-', + pprHeapOffset sty off2]) pprHeapOffset sty (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs) = pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs @@ -317,14 +314,12 @@ pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs case (catMaybes [pp_tothdr_offs, pp_varhdr_offs, pp_fxdhdr_offs, pp_int_offs]) of [] -> uppChar '0' [pp] -> pp -- Each blob is parenthesised if necessary - pps -> uppBesides [ uppLparen, uppIntersperse (uppChar '+') pps, uppRparen ] + pps -> uppParens (uppIntersperse (uppChar '+') pps) where pp_hdrs hdr_pp [] = Nothing pp_hdrs hdr_pp [SMRI(rep, n)] | n _EQ_ ILIT(1) = Just (uppBeside (uppStr (show rep)) hdr_pp) - pp_hdrs hdr_pp hdrs = Just (uppBesides [ uppLparen, - uppInterleave (uppChar '+') - (map (pp_hdr hdr_pp) hdrs), - uppRparen ]) + pp_hdrs hdr_pp hdrs = Just (uppParens (uppInterleave (uppChar '+') + (map (pp_hdr hdr_pp) hdrs))) pp_hdr :: Unpretty -> SMRep__Int -> Unpretty pp_hdr pp_str (SMRI(rep, n)) @@ -360,23 +355,22 @@ intOffsetIntoGoods anything_else = Nothing \end{code} \begin{code} -#if 0 #if ! OMIT_NATIVE_CODEGEN -hpRelToInt :: Target -> HeapOffset -> Int +hpRelToInt :: HeapOffset -> Int -hpRelToInt target (MaxHeapOffset left right) - = (hpRelToInt target left) `max` (hpRelToInt target right) +hpRelToInt ZeroHeapOffset = 0 -hpRelToInt target (SubHeapOffset left right) - = (hpRelToInt target left) - (hpRelToInt target right) +hpRelToInt (MaxHeapOffset left right) + = hpRelToInt left `max` hpRelToInt right -hpRelToInt target (AddHeapOffset left right) - = (hpRelToInt target left) + (hpRelToInt target right) +hpRelToInt (SubHeapOffset left right) + = hpRelToInt left - hpRelToInt right -hpRelToInt target ZeroHeapOffset = 0 +hpRelToInt (AddHeapOffset left right) + = hpRelToInt left + hpRelToInt right -hpRelToInt target (MkHeapOffset base fhs vhs ths) +hpRelToInt (MkHeapOffset base fhs vhs ths) = let vhs_pieces, ths_pieces :: [Int] fhs_off, vhs_off, ths_off :: Int @@ -390,9 +384,8 @@ hpRelToInt target (MkHeapOffset base fhs vhs ths) in IBOX(base) + fhs_off + vhs_off + ths_off where - fhs_size = (fixedHeaderSize target) :: Int - vhs_size r = (varHeaderSize target r) :: Int + fhs_size = fixedHdrSizeInWords + vhs_size r = varHdrSizeInWords r #endif -#endif {-0-} \end{code} diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 4b5dc29..d763bc7 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % %************************************************************************ %* * @@ -12,39 +12,46 @@ module PprAbsC ( writeRealC, - dumpRealC, + dumpRealC #if defined(DEBUG) - pprAmode, -- otherwise, not exported + , pprAmode -- otherwise, not exported #endif - - -- and for interface self-sufficiency... - AbstractC, CAddrMode, MagicId, - PprStyle, CSeq ) where -IMPORT_Trace -- ToDo: rm (debugging only) +import Ubiq{-uitous-} +import AbsCLoop -- break its dependence on ClosureInfo import AbsCSyn -import PrelInfo ( pprPrimOp, primOpNeedsWrapper, PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) +import AbsCUtils ( getAmodeRep, nonemptyAbsC, + mixedPtrLocn, mixedTypeLocn ) -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 Costs -- for GrAnSim; cost counting function -- HWL -import CostCentre -import FiniteMap -import Maybes ( catMaybes, maybeToBool, Maybe(..) ) -import Outputable -import Pretty ( codeStyle, prettyToUn ) -import PrimRep ( showPrimRep, isFloatingRep, PrimRep(..) ) -import StgSyn -import UniqFM +import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel, + isReadOnly, needsCDecl, pprCLabel, + CLabel{-instance Ord-} + ) +import CmdLineOpts ( opt_SccProfilingOn ) +import CostCentre ( uppCostCentre, uppCostCentreDecl ) +import Costs ( costs, addrModeCosts, CostRes(..), Side(..) ) +import CStrings ( stringToC ) +import FiniteMap ( addToFM, emptyFM, lookupFM ) +import HeapOffs ( isZeroOff, subOff, pprHeapOffset ) +import Literal ( showLiteral, Literal(..) ) +import Maybes ( maybeToBool, catMaybes ) +import PprStyle ( PprStyle(..) ) +import Pretty ( prettyToUn ) +import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) ) +import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) ) +import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, + isConstantRep, isSpecRep, isPhantomRep + ) +import Unique ( pprUnique, Unique{-instance NamedThing-} ) +import UniqSet ( emptyUniqSet, elementOfUniqSet, + addOneToUniqSet, UniqSet(..) + ) import Unpretty -- ********** NOTE ********** -import Util +import Util ( nOfThem, panic, assertPanic ) infixr 9 `thenTE` \end{code} @@ -55,18 +62,18 @@ call to a cost evaluation function @GRAN_EXEC@. For that, @pprAbsC@ has a new ``costs'' argument. %% HWL \begin{code} -writeRealC :: _FILE -> AbstractC -> PrimIO () +writeRealC :: _FILE -> AbstractC -> IO () -writeRealC sw_chker file absC +writeRealC file absC = uppAppendFile file 80 ( - uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n') + uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n') ) dumpRealC :: AbstractC -> String -dumpRealC sw_chker absC +dumpRealC absC = uppShow 80 ( - uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n') + uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n') ) \end{code} @@ -246,7 +253,7 @@ pprAbsC sty (CCodeBlock label abs_C) _ else "IFN_("), pprCLabel sty label, uppStr ") {"], case sty of - PprForC _ -> uppAbove pp_exts pp_temps + PprForC -> uppAbove pp_exts pp_temps _ -> uppNil, uppNest 8 (uppPStr SLIT("FB_")), uppNest 8 (pprAbsC sty abs_C (costs abs_C)), @@ -275,7 +282,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) -> uppAboves [ case sty of - PprForC _ -> pp_exts + PprForC -> pp_exts _ -> uppNil, uppBesides [ uppStr "SET_STATIC_HDR(", @@ -416,7 +423,7 @@ pprAbsC sty stmt@(CFlatRetVector label amodes) _ = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) -> uppAboves [ case sty of - PprForC _ -> pp_exts + PprForC -> pp_exts _ -> uppNil, uppBesides [ppLocalness label, uppPStr SLIT(" W_ "), pprCLabel sty label, uppStr "[] = {"], @@ -504,9 +511,9 @@ pp_basic_restores \begin{code} if_profiling sty pretty = case sty of - PprForC sw_chker -> if sw_chker SccProfilingOn - then pretty - else uppChar '0' -- leave it out! + PprForC -> if opt_SccProfilingOn + then pretty + else uppChar '0' -- leave it out! _ -> {-print it anyway-} pretty @@ -611,7 +618,6 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo = if (may_gc && liveness_mask /= noLiveRegsMask) then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n") else --- trace ("casm \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat localVars)) ++ (uppShow 80 (uppCat pp_non_void_args))) uppAboves [ uppChar '{', declare_local_vars, -- local var for *result* @@ -795,8 +801,8 @@ process_casm results args string = process results args string case readDec other of [(num,css)] -> if 0 <= num && num < length args - then uppBesides [uppLparen, args !! num, uppRparen, - process ress args css] + then uppBeside (uppParens (args !! num)) + (process ress args css) else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n") _ -> error ("process_casm: not % while processing _casm_ \"" ++ string ++ "\".\n") @@ -918,8 +924,8 @@ no-cast case: \begin{code} pprAmode sty amode | mixedTypeLocn amode - = uppBesides [ uppLparen, pprPrimKind sty (getAmodeRep amode), uppStr ")(", - ppr_amode sty amode, uppRparen] + = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppStr ")(", + ppr_amode sty amode ]) | otherwise -- No cast needed = ppr_amode sty amode \end{code} @@ -930,7 +936,7 @@ Now the rest of the cases for ``workhorse'' @ppr_amode@: ppr_amode sty (CVal reg_rel _) = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of (pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg - (pp_reg, Just offset) -> uppBesides [ pp_reg, uppLbrack, offset, uppRbrack ] + (pp_reg, Just offset) -> uppBesides [ pp_reg, uppBracket offset ] ppr_amode sty (CAddr reg_rel) = case (pprRegRelative sty True{-sign wanted-} reg_rel) of @@ -1149,19 +1155,13 @@ x `elementOfCLabelSet` labs = case (lookupFM labs x) of { Just _ -> True; Nothing -> False } addToCLabelSet set x = addToFM set x () -type UniqueSet = UniqFM () -emptyUniqueSet = emptyUFM -x `elementOfUniqueSet` us - = case (lookupDirectlyUFM us x) of { Just _ -> True; Nothing -> False } -addToUniqueSet set x = set `plusUFM` singletonDirectlyUFM x () - -type TEenv = (UniqueSet, CLabelSet) +type TEenv = (UniqSet Unique, CLabelSet) type TeM result = TEenv -> (TEenv, result) initTE :: TeM a -> a initTE sa - = case sa (emptyUniqueSet, emptyCLabelSet) of { (_, result) -> + = case sa (emptyUniqSet, emptyCLabelSet) of { (_, result) -> result } {-# INLINE thenTE #-} @@ -1188,9 +1188,9 @@ returnTE result env = (env, result) tempSeenTE :: Unique -> TeM Bool tempSeenTE uniq env@(seen_uniqs, seen_labels) - = if (uniq `elementOfUniqueSet` seen_uniqs) + = if (uniq `elementOfUniqSet` seen_uniqs) then (env, True) - else ((addToUniqueSet seen_uniqs uniq, + else ((addOneToUniqSet seen_uniqs uniq, seen_labels), False) @@ -1208,8 +1208,6 @@ 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 -> PrimRep -> Unpretty pprExternDecl clabel kind @@ -1222,7 +1220,7 @@ pprExternDecl clabel kind _ -> ppLocalnessMacro False{-data-} clabel ) _TO_ pp_macro_str -> - uppBesides [ pp_macro_str, uppLparen, pprCLabel ppr_for_C clabel, pp_paren_semi ] + uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ] BEND \end{code} diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs new file mode 100644 index 0000000..d28c6c5 --- /dev/null +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -0,0 +1,45 @@ +% +% (c) The AQUA Project, Glasgow University, 1996 +% +\section[FieldLabel]{The @FieldLabel@ type} + +\begin{code} +#include "HsVersions.h" + +module FieldLabel where + +import Ubiq{-uitous-} + +import Name ( Name{-instance Eq/Outputable-} ) +import Type ( Type(..) ) +\end{code} + +\begin{code} +data FieldLabel + = FieldLabel Name + Type + FieldLabelTag + +type FieldLabelTag = Int + +mkFieldLabel = FieldLabel + +firstFieldLabelTag :: FieldLabelTag +firstFieldLabelTag = 1 + +allFieldLabelTags :: [FieldLabelTag] +allFieldLabelTags = [1..] + +fieldLabelName (FieldLabel n _ _) = n +fieldLabelType (FieldLabel _ ty _) = ty +fieldLabelTag (FieldLabel _ _ tag) = tag + +instance Eq FieldLabel where + (FieldLabel n1 _ _) == (FieldLabel n2 _ _) = n1 == n2 + +instance Outputable FieldLabel where + ppr sty (FieldLabel n _ _) = ppr sty n + +instance NamedThing FieldLabel + -- ToDo: fill this in +\end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index ec6367e..6c1d19b 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -32,12 +32,15 @@ module Id {- ( idType, getIdInfo, replaceIdInfo, getPragmaInfo, - getIdPrimRep, getInstIdModule, + idPrimRep, getInstIdModule, getMentionedTyConsAndClassesFromId, - getDataConTag, - getDataConSig, getInstantiatedDataConSig, - getDataConTyCon, + dataConTag, + dataConSig, getInstantiatedDataConSig, + dataConTyCon, dataConArity, + dataConFieldLabels, + + recordSelectorFieldLabel, -- PREDICATES isDataCon, isTupleCon, @@ -62,7 +65,7 @@ module Id {- ( -- not exported: apply_to_Id, -- please don't use this, generally -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc) - getIdArity, getDataConArity, addIdArity, + getIdArity, addIdArity, getIdDemandInfo, addIdDemandInfo, getIdSpecialisation, addIdSpecialisation, getIdStrictness, addIdStrictness, @@ -96,30 +99,38 @@ import NameLoop -- for paranoia checking import Bag import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp ) +import CStrings ( identToC, cSEP ) import IdInfo import Maybes ( maybeToBool ) import NameTypes ( mkShortName, fromPrelude, FullName, ShortName ) +import FieldLabel ( fieldLabelName, FieldLabel{-instances-} ) import Name ( Name(..) ) import Outputable ( isAvarop, isAconop, getLocalName, isExported, ExportFlag(..) ) import PragmaInfo ( PragmaInfo(..) ) import PrelMods ( pRELUDE_BUILTIN ) -import PprType ( GenType, GenTyVar, - getTypeString, typeMaybeString, specMaybeTysSuffix ) +import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix, + GenType, GenTyVar + ) import PprStyle import Pretty import SrcLoc ( mkBuiltinSrcLoc ) -import TyCon ( TyCon, mkTupleTyCon, getTyConDataCons ) +import TyCon ( TyCon, mkTupleTyCon, tyConDataCons ) import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, applyTyCon, isPrimType, instantiateTy, - tyVarsOfType, + tyVarsOfType, applyTypeEnvToTy, typePrimRep, GenType, ThetaType(..), TauType(..), Type(..) ) -import TyVar ( GenTyVar, alphaTyVars, isEmptyTyVarSet ) +import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) ) import UniqFM import UniqSet -- practically all of it -import Unique ( Unique, mkTupleDataConUnique, pprUnique, showUnique ) -import Util ( mapAccumL, nOfThem, panic, pprPanic, assertPanic ) +import UniqSupply ( getBuiltinUniques ) +import Unique ( mkTupleDataConUnique, pprUnique, showUnique, + Unique{-instance Ord3-} + ) +import Util ( mapAccumL, nOfThem, + panic, panic#, pprPanic, assertPanic + ) \end{code} Here are the @Id@ and @IdDetails@ datatypes; also see the notes that @@ -176,6 +187,7 @@ data IdDetails | DataConId FullName ConTag [StrictnessMark] -- Strict args; length = arity + [FieldLabel] -- Field labels for this constructor [TyVar] [(Class,Type)] [Type] TyCon -- the type is: @@ -184,6 +196,8 @@ data IdDetails | TupleConId Int -- Its arity + | RecordSelectorId FieldLabel + ---------------- Things to do with overloading | SuperDictSelId -- Selector for superclass dictionary @@ -229,6 +243,7 @@ data IdDetails | InstId ShortName -- An instance of a dictionary, class operation, -- or overloaded value + Bool -- as for LocalId | SpecId -- A specialisation of another Id Id -- Id of which this is a specialisation @@ -437,10 +452,10 @@ 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 + 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) @@ -476,29 +491,31 @@ idHasNoFreeTyVars :: Id -> Bool 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 (MethodSelId _ _) = True - chk (DefaultMethodId _ _ _) = True - chk (DictFunId _ _ _ _) = True - chk (ConstMethodId _ _ _ _ _) = True - 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 + chk (DataConId _ _ _ _ _ _ _ _) = True + chk (TupleConId _) = True + chk (RecordSelectorId _) = 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 + -- 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 idHasNoFreeTyVars (Id _ _ details _ info) = chk details where - chk (DataConId _ _ _ _ _ _ _) = True + chk (DataConId _ _ _ _ _ _ _ _) = True chk (TupleConId _) = True + chk (RecordSelectorId _) = True chk (ImportedId _) = True chk (PreludeId _) = True chk (TopLevId _) = True @@ -508,7 +525,7 @@ idHasNoFreeTyVars (Id _ _ details _ info) chk (DictFunId _ _ _ _) = True chk (ConstMethodId _ _ _ _ _) = True chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr - chk (InstId _) = False -- these are local + chk (InstId _ no_free_tvs) = no_free_tvs chk (SpecId _ _ no_free_tvs) = no_free_tvs chk (LocalId _ no_free_tvs) = no_free_tvs chk (SysLocalId _ no_free_tvs) = no_free_tvs @@ -522,8 +539,7 @@ isTopLevId other = False isImportedId (Id _ _ (ImportedId _) _ _) = True isImportedId other = False -isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented" - -- LATER: bottomIsGuaranteed (getInfo info) +isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info) isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True isSysLocalId other = False @@ -578,7 +594,7 @@ pprIdInUnfolding in_scopes v else if v == nilDataCon then ppPStr SLIT("_NIL_") else if isTupleCon v then - ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v)) + ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v)) -- ones to think about: else @@ -592,7 +608,9 @@ pprIdInUnfolding in_scopes v -- these ones' exportedness checked later... TopLevId _ -> pp_full_name - DataConId _ _ _ _ _ _ _ -> pp_full_name + DataConId _ _ _ _ _ _ _ _ -> pp_full_name + + RecordSelectorId lbl -> ppr sty lbl -- class-ish things: class already recorded as "mentioned" SuperDictSelId c sc @@ -754,14 +772,10 @@ unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) -- TyVar(Templates) in the i/face; only a problem -- if -fshow-pragma-name-errs; but we can do without the pain. -- A HACK in any case (WDP 94/05/02) - = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) ( - naughty_DictFunId dfun - --) + = naughty_DictFunId dfun unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _) - = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) ( - naughty_DictFunId dfun -- similar deal... - --) + = naughty_DictFunId dfun -- similar deal... unfoldingUnfriendlyId other_id = False -- is friendly in all other cases @@ -785,9 +799,6 @@ compiling the prelude, the compiler may not recognise that as true. \begin{code} externallyVisibleId :: Id -> Bool -externallyVisibleId id = panic "Id.externallyVisibleId" -{-LATER: - externallyVisibleId id@(Id _ _ details _ _) = if isLocallyDefined id then toplevelishId id && isExported id && not (weird_datacon details) @@ -805,26 +816,22 @@ externallyVisibleId id@(Id _ _ details _ _) -- of WeirdLocalType; but we need to know this when asked if -- "Mumble" is externally visible... - weird_datacon (DataConId _ _ _ _ _ _ tycon) +{- LATER: if at all: + 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} idWantsToBeINLINEd :: Id -> Bool -idWantsToBeINLINEd id - = panic "Id.idWantsToBeINLINEd" -{- LATER: - = case (getIdUnfolding id) of - IWantToBeINLINEd _ -> True - _ -> False --} +idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True +idWantsToBeINLINEd _ = False \end{code} For @unlocaliseId@: See the brief commentary in @@ -861,7 +868,7 @@ unlocaliseId mod (Id u ty info (WorkerId unwrkr)) Nothing -> Nothing Just xx -> Just (Id u ty info (WorkerId xx)) -unlocaliseId mod (Id u ty info (InstId name)) +unlocaliseId mod (Id u ty info (InstId name no_ftvs)) = Just (Id u ty info (TopLevId full_name)) -- type might be wrong, but it hardly matters -- at this stage (just before printing C) ToDo @@ -902,41 +909,37 @@ The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the former ``should be'' the usual crunch point. \begin{code} -{-LATER: +type TypeEnv = TyVarEnv Type + applyTypeEnvToId :: TypeEnv -> Id -> Id -applyTypeEnvToId type_env id@(Id u ty info details) +applyTypeEnvToId type_env id@(Id _ ty _ _ _) | idHasNoFreeTyVars id = id | otherwise = apply_to_Id ( \ ty -> applyTypeEnvToTy type_env ty ) id --} \end{code} \begin{code} -{-LATER: apply_to_Id :: (Type -> Type) -> Id -> Id -apply_to_Id ty_fn (Id u ty info details) - = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details) +apply_to_Id ty_fn (Id u ty details prag info) + = let + new_ty = ty_fn ty + in + Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info) where - apply_to_details (InstId inst) - = let - new_inst = apply_to_Inst ty_fn inst - in - InstId new_inst - apply_to_details (SpecId unspec ty_maybes no_ftvs) = let new_unspec = apply_to_Id ty_fn unspec new_maybes = map apply_to_maybe ty_maybes in - SpecId new_unspec new_maybes no_ftvs - -- ToDo: recalc no_ftvs???? + SpecId new_unspec new_maybes (no_free_tvs ty) + -- ToDo: gratuitous recalc no_ftvs???? (also InstId) where apply_to_maybe Nothing = Nothing apply_to_maybe (Just ty) = Just (ty_fn ty) @@ -948,7 +951,6 @@ apply_to_Id ty_fn (Id u ty info details) WorkerId new_unwrkr apply_to_details other = other --} \end{code} Sadly, I don't think the one using the magic typechecker substitution @@ -970,9 +972,9 @@ applySubstToId subst id@(Id u ty info details) case (apply_to_details s3 new_ty details) of { (s4, new_details) -> (s4, Id u new_ty new_info new_details) }}} where - apply_to_details subst _ (InstId inst) + apply_to_details subst _ (InstId inst no_ftvs) = case (applySubstToInst subst inst) of { (s2, new_inst) -> - (s2, InstId new_inst) } + (s2, InstId new_inst no_ftvs{-ToDo:right???-}) } apply_to_details subst new_ty (SpecId unspec ty_maybes _) = case (applySubstToId subst unspec) of { (s2, new_unspec) -> @@ -995,18 +997,21 @@ applySubstToId subst id@(Id u ty info details) \begin{code} 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 _ _ _ _ _ _ -> + DataConId n _ _ _ _ _ _ _ -> case (getOrigName n) of { (mod, name) -> if fromPrelude mod then [name] else [mod, name] } TupleConId 0 -> [SLIT("()")] TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )] + RecordSelectorId lbl -> panic "getIdNamePieces:RecordSelectorId" + ImportedId n -> get_fullname_pieces n PreludeId n -> get_fullname_pieces n TopLevId n -> get_fullname_pieces n @@ -1075,7 +1080,7 @@ getIdNamePieces show_uniqs id LocalId n _ -> let local = getLocalName n in if show_uniqs then [local, showUnique u] else [local] - InstId n -> [getLocalName n, showUnique u] + InstId n _ -> [getLocalName n, showUnique u] SysLocalId n _ -> [getLocalName n, showUnique u] SpecPragmaId n _ _ -> [getLocalName n, showUnique u] @@ -1110,7 +1115,7 @@ getMentionedTyConsAndClassesFromId id \end{code} \begin{code} ---getIdPrimRep i = primRepFromType (idType i) +idPrimRep i = typePrimRep (idType i) \end{code} \begin{code} @@ -1140,7 +1145,7 @@ mkConstMethodId u c op ity full_ty from_here modname info mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info -mkInstId uniq ty name = Id uniq ty (InstId name) NoPragmaInfo noIdInfo +mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo {-LATER: getConstMethodId clas op ty @@ -1151,14 +1156,13 @@ getConstMethodId clas op ty 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, + Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [ + ppCat [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} @@ -1228,36 +1232,29 @@ mkSameSpecCon ty_maybes unspec@(Id u ty info details) where new_ty = specialiseTy ty ty_maybes 0 - -- pprTrace "SameSpecCon:Unique:" - -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes])) - localiseId :: Id -> Id localiseId id@(Id u ty info details) = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty)) where name = getOccurrenceName id loc = getSrcLoc id +-} --- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId) --- ToDo: it does??? WDP mkIdWithNewUniq :: Id -> Unique -> Id -mkIdWithNewUniq (Id _ ty info details) uniq - = Id uniq ty info new_details --} +mkIdWithNewUniq (Id _ ty details prag info) uniq + = Id uniq ty details prag info \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} -{-LATER: mkTemplateLocals :: [Type] -> [Id] mkTemplateLocals tys - = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc) + = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc) (getBuiltinUniques (length tys)) tys --} \end{code} \begin{code} @@ -1293,11 +1290,11 @@ besides the code-generator need arity info!) getIdArity :: Id -> ArityInfo getIdArity (Id _ _ _ _ id_info) = getInfo id_info -getDataConArity :: DataCon -> Int -getDataConArity id@(Id _ _ _ _ id_info) +dataConArity :: DataCon -> Int +dataConArity id@(Id _ _ _ _ id_info) = ASSERT(isDataCon id) case (arityMaybe (getInfo id_info)) of - Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id) + Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) Just i -> i addIdArity :: Id -> Int -> Id @@ -1314,13 +1311,13 @@ addIdArity (Id u ty details pinfo info) arity \begin{code} mkDataCon :: Unique{-DataConKey-} -> FullName - -> [StrictnessMark] + -> [StrictnessMark] -> [FieldLabel] -> [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 +mkDataCon k n stricts fields tvs ctxt args_tys tycon = ASSERT(length stricts == length args_tys) data_con where @@ -1329,13 +1326,13 @@ mkDataCon k n stricts tvs ctxt args_tys tycon data_con = Id k type_of_constructor - (DataConId n data_con_tag stricts tvs ctxt args_tys tycon) + (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon) NoPragmaInfo datacon_info data_con_tag = position_within fIRST_TAG data_con_family - data_con_family = getTyConDataCons tycon + data_con_family = tyConDataCons tycon position_within :: Int -> [Id] -> Int @@ -1450,36 +1447,53 @@ fIRST_TAG = 1 -- Tags allocated from here for real constructors \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 +dataConTag :: DataCon -> ConTag -- will panic if not a DataCon +dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag +dataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG +dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec -getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon -getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon -getDataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a +dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon +dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon +dataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a -getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) +dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) -- will panic if not a DataCon -getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _) +dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _) = (tyvars, theta_ty, arg_tys, tycon) -getDataConSig (Id _ _ (TupleConId arity) _ _) +dataConSig (Id _ _ (TupleConId arity) _ _) = (tyvars, [], tyvar_tys, mkTupleTyCon arity) where tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars + +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields +\end{code} + +\begin{code} +mkRecordSelectorId field_label selector_ty + = Id (getItsUnique name) + selector_ty + (RecordSelectorId field_label) + NoPragmaInfo + noIdInfo + where + name = fieldLabelName field_label + +recordSelectorFieldLabel :: Id -> FieldLabel +recordSelectorFieldLabel (Id _ _ (RecordSelectorId lbl) _ _) = lbl \end{code} {- LATER -getDataConTyCon (Id _ _ _ (SpecId unspec tys _)) - = mkSpecTyCon (getDataConTyCon unspec) tys +dataConTyCon (Id _ _ _ (SpecId unspec tys _)) + = mkSpecTyCon (dataConTyCon unspec) tys -getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) +dataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon) where - (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec + (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec ty_env = tyvars `zip` ty_maybes @@ -1493,7 +1507,7 @@ getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) spec_arg_tys = map (instantiateTauTy spec_env) arg_tys spec_theta_ty = if null theta_ty then [] - else panic "getDataConSig:ThetaTy:SpecDataCon" + else panic "dataConSig:ThetaTy:SpecDataCon" spec_tycon = mkSpecTyCon tycon ty_maybes -} \end{code} @@ -1516,7 +1530,7 @@ getInstantiatedDataConSig :: getInstantiatedDataConSig data_con inst_tys = ASSERT(isDataCon data_con) let - (tvs, theta, arg_tys, tycon) = getDataConSig data_con + (tvs, theta, arg_tys, tycon) = dataConSig data_con inst_env = ASSERT(length tvs == length inst_tys) tvs `zip` inst_tys @@ -1698,7 +1712,6 @@ 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 @@ -1711,18 +1724,12 @@ cmpId_withSpecDataCon id1 id2 cmp_ids = cmpId id1 id2 eq_ids = case cmp_ids of { EQ_ -> True; other -> False } -cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _)) (Id _ _ _ (SpecId _ mtys2 _)) - = cmpUniTypeMaybeList mtys1 mtys2 - -cmpEqDataCon unspec1 (Id _ _ _ (SpecId _ _ _)) - = LT_ - -cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2 - = GT_ +cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _) + = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2" -cmpEqDataCon unspec1 unspec2 - = EQ_ --} +cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_ +cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_ +cmpEqDataCon _ _ = EQ_ \end{code} %************************************************************************ @@ -1735,6 +1742,10 @@ cmpEqDataCon unspec1 unspec2 instance Outputable ty => Outputable (GenId ty) where ppr sty id = pprId sty id +-- and a SPECIALIZEd one: +instance Outputable {-Id, i.e.:-}(GenId Type) where + ppr sty id = pprId sty id + showId :: PprStyle -> Id -> String showId sty id = ppShow 80 (pprId sty id) @@ -1778,13 +1789,12 @@ pprId other_sty id = let pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id - for_code = panic "pprId: for code" - {- = let + 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 @@ -1810,12 +1820,12 @@ pprId other_sty id = 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 + 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 (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. @@ -1834,8 +1844,9 @@ 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 (RecordSelectorId l) = getExportFlag l get (ImportedId n) = getExportFlag n get (PreludeId n) = getExportFlag n get (TopLevId n) = getExportFlag n @@ -1846,7 +1857,7 @@ instance NamedThing (GenId ty) where get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here get (SpecId unspec _ _) = getExportFlag unspec get (WorkerId unwrkr) = getExportFlag unwrkr - get (InstId _) = NotExported + get (InstId _ _) = NotExported get (LocalId _ _) = NotExported get (SysLocalId _ _) = NotExported get (SpecPragmaId _ _ _) = NotExported @@ -1854,10 +1865,11 @@ instance NamedThing (GenId ty) where 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 (RecordSelectorId l) = isLocallyDefined l get (TopLevId n) = isLocallyDefined n get (SuperDictSelId c _) = isLocallyDefined c get (MethodSelId c _) = isLocallyDefined c @@ -1870,7 +1882,7 @@ instance NamedThing (GenId ty) where get (ConstMethodId c tyc _ from_here _) = from_here get (SpecId unspec _ _) = isLocallyDefined unspec get (WorkerId unwrkr) = isLocallyDefined unwrkr - get (InstId _) = True + get (InstId _ _) = True get (LocalId _ _) = True get (SysLocalId _ _) = True get (SpecPragmaId _ _ _) = True @@ -1878,9 +1890,10 @@ instance NamedThing (GenId ty) where getOrigName this_id@(Id u _ details _ _) = get details where - get (DataConId n _ _ _ _ _ _) = getOrigName n + get (DataConId n _ _ _ _ _ _ _) = getOrigName n get (TupleConId 0) = (pRELUDE_BUILTIN, SLIT("()")) get (TupleConId a) = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )) + get (RecordSelectorId l)= getOrigName l get (ImportedId n) = getOrigName n get (PreludeId n) = getOrigName n get (TopLevId n) = getOrigName n @@ -1911,7 +1924,7 @@ instance NamedThing (GenId ty) where BEND -} - get (InstId n) = (panic "NamedThing.Id.getOrigName (LocalId)", + get (InstId n _) = (panic "NamedThing.Id.getOrigName (LocalId)", getLocalName n) get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)", getLocalName n) @@ -1933,9 +1946,10 @@ instance NamedThing (GenId ty) where getOccurrenceName this_id@(Id _ _ details _ _) = get details where - get (DataConId n _ _ _ _ _ _) = getOccurrenceName n + get (DataConId n _ _ _ _ _ _ _) = getOccurrenceName n get (TupleConId 0) = SLIT("()") get (TupleConId a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ) + get (RecordSelectorId l)= getOccurrenceName l get (ImportedId n) = getOccurrenceName n get (PreludeId n) = getOccurrenceName n get (TopLevId n) = getOccurrenceName n @@ -1947,8 +1961,9 @@ instance NamedThing (GenId ty) where getSrcLoc (Id _ _ details _ id_info) = get details where - get (DataConId n _ _ _ _ _ _) = getSrcLoc n + get (DataConId n _ _ _ _ _ _ _) = getSrcLoc n get (TupleConId _) = mkBuiltinSrcLoc + get (RecordSelectorId l)= getSrcLoc l get (ImportedId n) = getSrcLoc n get (PreludeId n) = getSrcLoc n get (TopLevId n) = getSrcLoc n @@ -1956,7 +1971,7 @@ instance NamedThing (GenId ty) where get (MethodSelId c _) = getSrcLoc c get (SpecId unspec _ _) = getSrcLoc unspec get (WorkerId unwrkr) = getSrcLoc unwrkr - get (InstId n) = getSrcLoc n + get (InstId n _) = getSrcLoc n get (LocalId n _) = getSrcLoc n get (SysLocalId n _) = getSrcLoc n get (SpecPragmaId n _ _)= getSrcLoc n @@ -1968,8 +1983,9 @@ instance NamedThing (GenId ty) where 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 (RecordSelectorId l) = fromPreludeCore l get (ImportedId n) = fromPreludeCore n get (PreludeId n) = fromPreludeCore n get (TopLevId n) = fromPreludeCore n @@ -1980,7 +1996,7 @@ instance NamedThing (GenId ty) where 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 @@ -2030,7 +2046,7 @@ mapIdEnv = mapUFM mkIdEnv = listToUFM nullIdEnv = emptyUFM rngIdEnv = eltsUFM -unitIdEnv = singletonUFM +unitIdEnv = unitUFM growIdEnvList env pairs = plusUFM env (listToUFM pairs) isNullIdEnv env = sizeUFM env == 0 @@ -2054,14 +2070,16 @@ intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty idSetToList :: GenIdSet ty -> [GenId ty] -singletonIdSet :: GenId ty -> GenIdSet ty +unitIdSet :: GenId ty -> GenIdSet ty +addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty isEmptyIdSet :: GenIdSet ty -> Bool mkIdSet :: [GenId ty] -> GenIdSet ty emptyIdSet = emptyUniqSet -singletonIdSet = singletonUniqSet +unitIdSet = unitUniqSet +addOneToIdSet = addOneToUniqSet intersectIdSets = intersectUniqSets unionIdSets = unionUniqSets unionManyIdSets = unionManyUniqSets diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index b2594b3..8f35f6a 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -76,7 +76,7 @@ import IdLoop -- IdInfo is a dependency-loop ranch, and import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( firstJust ) -import MatchEnv ( nullMEnv, mEnvToList ) +import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList ) import Outputable ( ifPprInterface, Outputable(..){-instances-} ) import PprStyle ( PprStyle(..) ) import Pretty @@ -85,7 +85,6 @@ 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" @@ -180,8 +179,11 @@ Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@ 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 +apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc) + | isEmptyMEnv spec + = idinfo + | otherwise = panic "IdInfo:apply_to_IdInfo" {- LATER: let diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi index 7cc2c63..bdc4f12 100644 --- a/ghc/compiler/basicTypes/IdLoop.lhi +++ b/ghc/compiler/basicTypes/IdLoop.lhi @@ -17,10 +17,10 @@ import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId, ) import IdInfo ( IdInfo ) import Literal ( Literal ) -import MagicUFs ( MagicUnfoldingFun ) +import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle ) -import PprType ( pprParendType ) +import PprType ( pprParendGenType ) import Pretty ( PrettyRep ) import Type ( GenType ) import TyVar ( GenTyVar ) @@ -39,9 +39,11 @@ 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 +pprParendGenType :: (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 +mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun + type IdEnv a = UniqFM a type CoreExpr = GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 00fcbab..c809a49 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -28,7 +28,7 @@ import Outputable ( ExportFlag(..) ) import Pretty import PprStyle ( PprStyle(..) ) import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) -import TyCon ( TyCon, getSynTyConArity ) +import TyCon ( TyCon, synTyConArity ) import TyVar ( GenTyVar ) import Unique ( pprUnique, Unique ) import Util ( panic, panic#, pprPanic ) @@ -129,7 +129,7 @@ getTagFromClassOpName (ClassOpName _ _ _ tag) = tag getSynNameArity :: Name -> Maybe Arity getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity -getSynNameArity (WiredInTyCon tycon) = getSynTyConArity tycon +getSynNameArity (WiredInTyCon tycon) = synTyConArity tycon getSynNameArity other_name = Nothing getNameShortName :: Name -> ShortName diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs new file mode 100644 index 0000000..1cd1071 --- /dev/null +++ b/ghc/compiler/basicTypes/PprEnv.lhs @@ -0,0 +1,121 @@ +% +% (c) The AQUA Project, Glasgow University, 1996 +% +\section[PprEnv]{The @PprEnv@ type} + +\begin{code} +#include "HsVersions.h" + +module PprEnv ( + PprEnv{-abstract-}, + + initPprEnv, + + pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle, + pTy, pTyVar, pUVar, pUse + ) where + +import Ubiq{-uitous-} + +import Id ( DataCon(..) ) +import Pretty ( Pretty(..) ) +import Util ( panic ) +\end{code} + +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 PprEnv tyvar uvar bndr occ + = PE PprStyle -- stored for safe keeping + + (Literal -> Pretty) -- Doing these this way saves + (DataCon -> Pretty) -- carrying around a PprStyle + (PrimOp -> Pretty) + (CostCentre -> Pretty) + + (tyvar -> Pretty) -- to print tyvars + (uvar -> Pretty) -- to print usage vars + + (bndr -> Pretty) -- to print "major" val_bdrs + (bndr -> Pretty) -- to print "minor" val_bdrs + (occ -> Pretty) -- to print bindees + + (GenType tyvar uvar -> Pretty) + (GenUsage uvar -> Pretty) +\end{code} + +\begin{code} +initPprEnv + :: PprStyle + -> Maybe (Literal -> Pretty) + -> Maybe (DataCon -> Pretty) + -> Maybe (PrimOp -> Pretty) + -> Maybe (CostCentre -> Pretty) + -> Maybe (tyvar -> Pretty) + -> Maybe (uvar -> Pretty) + -> Maybe (bndr -> Pretty) + -> Maybe (bndr -> Pretty) + -> Maybe (occ -> Pretty) + -> Maybe (GenType tyvar uvar -> Pretty) + -> Maybe (GenUsage uvar -> Pretty) + -> PprEnv tyvar uvar bndr occ + +-- you can specify all the printers individually; if +-- you don't specify one, you get bottom + +initPprEnv sty l d p c tv uv maj_bndr min_bndr occ ty use + = PE sty + (demaybe l) + (demaybe d) + (demaybe p) + (demaybe c) + (demaybe tv) + (demaybe uv) + (demaybe maj_bndr) + (demaybe min_bndr) + (demaybe occ) + (demaybe ty) + (demaybe use) + where + demaybe Nothing = bottom + demaybe (Just x) = x + + bottom = panic "PprEnv.initPprEnv: unspecified printing function" + +{- +initPprEnv sty pmaj pmin pocc + = PE (ppr sty) -- for a Literal + (ppr sty) -- for a DataCon + (ppr sty) -- for a PrimOp + (\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre + + (ppr sty) -- for a tyvar + (ppr sty) -- for a usage var + + pmaj pmin pocc -- for GenIds in various guises + + (ppr sty) -- for a Type + (ppr sty) -- for a Usage +-} +\end{code} + +\begin{code} +pStyle (PE s _ _ _ _ _ _ _ _ _ _ _) = s +pLit (PE _ pp _ _ _ _ _ _ _ _ _ _) = pp +pCon (PE _ _ pp _ _ _ _ _ _ _ _ _) = pp +pPrim (PE _ _ _ pp _ _ _ _ _ _ _ _) = pp +pSCC (PE _ _ _ _ pp _ _ _ _ _ _ _) = pp + +pTyVar (PE _ _ _ _ _ pp _ _ _ _ _ _) = pp +pUVar (PE _ _ _ _ _ _ pp _ _ _ _ _) = pp + +pMajBndr (PE _ _ _ _ _ _ _ pp _ _ _ _) = pp +pMinBndr (PE _ _ _ _ _ _ _ _ pp _ _ _) = pp +pOcc (PE _ _ _ _ _ _ _ _ _ pp _ _) = pp + +pTy (PE _ _ _ _ _ _ _ _ _ _ pp _) = pp +pUse (PE _ _ _ _ _ _ _ _ _ _ _ pp) = pp +\end{code} diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 81fec96..1915538 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -15,6 +15,7 @@ module UniqSupply ( UniqSM(..), -- type: unique supply monad initUs, thenUs, returnUs, mapUs, mapAndUnzipUs, mapAndUnzip3Us, + thenMaybeUs, mapAccumLUs, mkSplitUniqSupply, splitUniqSupply, @@ -169,6 +170,24 @@ mapAndUnzip3Us f (x:xs) = f x `thenUs` \ (r1, r2, r3) -> mapAndUnzip3Us f xs `thenUs` \ (rs1, rs2, rs3) -> returnUs (r1:rs1, r2:rs2, r3:rs3) + +thenMaybeUs :: UniqSM (Maybe a) -> (a -> UniqSM (Maybe b)) -> UniqSM (Maybe b) +thenMaybeUs m k + = m `thenUs` \ result -> + case result of + Nothing -> returnUs Nothing + Just x -> k x + +mapAccumLUs :: (acc -> x -> UniqSM (acc, y)) + -> acc + -> [x] + -> UniqSM (acc, [y]) + +mapAccumLUs f b [] = returnUs (b, []) +mapAccumLUs f b (x:xs) + = f b x `thenUs` \ (b__2, x__2) -> + mapAccumLUs f b__2 xs `thenUs` \ (b__3, xs__2) -> + returnUs (b__3, x__2:xs__2) \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 84fd884..4d17fc1 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -8,7 +8,7 @@ module CgBindery ( CgBindings(..), CgIdInfo(..){-dubiously concrete-}, - StableLoc, VolatileLoc, LambdaFormInfo{-re-exported-}, + StableLoc, VolatileLoc, maybeAStkLoc, maybeBStkLoc, @@ -20,25 +20,35 @@ module CgBindery ( bindNewToAStack, bindNewToBStack, bindNewToNode, bindNewToReg, bindArgsToRegs, bindNewToTemp, bindNewPrimToAmode, - getAtomAmode, getAtomAmodes, + getArgAmode, getArgAmodes, getCAddrModeAndInfo, getCAddrMode, getCAddrModeIfVolatile, getVolatileRegs, rebindToAStack, rebindToBStack - - -- and to make a self-sufficient interface... ) where +import Ubiq{-uitous-} +import CgLoop1 -- here for paranoia-checking + import AbsCSyn import CgMonad import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset ) -import CLabel ( mkClosureLabel, CLabel ) -import ClosureInfo -import Id ( getIdPrimRep, toplevelishId, isDataCon, Id ) -import Maybes ( catMaybes, Maybe(..) ) -import UniqSet -- ( setToList ) -import StgSyn -import Util +import CLabel ( mkClosureLabel ) +import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument ) +import HeapOffs ( VirtualHeapOffset(..), + VirtualSpAOffset(..), VirtualSpBOffset(..) + ) +import Id ( idPrimRep, toplevelishId, isDataCon, + mkIdEnv, rngIdEnv, IdEnv(..), + idSetToList, + GenId{-instance NamedThing-} + ) +import Maybes ( catMaybes ) +import PprAbsC ( pprAmode ) +import PprStyle ( PprStyle(..) ) +import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) ) +import Unpretty ( uppShow ) +import Util ( zipWithEqual, panic ) \end{code} @@ -113,13 +123,13 @@ newTempAmodeAndIdInfo name lf_info = (temp_amode, temp_idinfo) where uniq = getItsUnique name - temp_amode = CTemp uniq (getIdPrimRep name) + temp_amode = CTemp uniq (idPrimRep name) temp_idinfo = tempIdInfo name uniq lf_info -idInfoToAmode :: PrimKind -> CgIdInfo -> FCode CAddrMode +idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab -idInfoPiecesToAmode :: PrimKind -> VolatileLoc -> StableLoc -> FCode CAddrMode +idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind) idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id) @@ -195,7 +205,7 @@ getCAddrModeAndInfo name returnFC (amode, lf_info) where global_amode = CLbl (mkClosureLabel name) kind - kind = getIdPrimRep name + kind = idPrimRep name getCAddrMode :: Id -> FCode CAddrMode getCAddrMode name @@ -211,7 +221,7 @@ getCAddrModeIfVolatile name = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) -> case stable_loc of NoStableLoc -> -- Aha! So it is volatile! - idInfoPiecesToAmode (getIdPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode -> + idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode -> returnFC (Just amode) a_stable_loc -> returnFC Nothing @@ -228,7 +238,7 @@ forget the volatile one. getVolatileRegs :: StgLiveVars -> FCode [MagicId] getVolatileRegs vars - = mapFCs snaffle_it (uniqSetToList vars) `thenFC` \ stuff -> + = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff -> returnFC (catMaybes stuff) where snaffle_it var @@ -262,17 +272,17 @@ getVolatileRegs vars \end{code} \begin{code} -getAtomAmodes :: [StgArg] -> FCode [CAddrMode] -getAtomAmodes [] = returnFC [] -getAtomAmodes (atom:atoms) - = getAtomAmode atom `thenFC` \ amode -> - getAtomAmodes atoms `thenFC` \ amodes -> +getArgAmodes :: [StgArg] -> FCode [CAddrMode] +getArgAmodes [] = returnFC [] +getArgAmodes (atom:atoms) + = getArgAmode atom `thenFC` \ amode -> + getArgAmodes atoms `thenFC` \ amodes -> returnFC ( amode : amodes ) -getAtomAmode :: StgArg -> FCode CAddrMode +getArgAmode :: StgArg -> FCode CAddrMode -getAtomAmode (StgVarArg var) = getCAddrMode var -getAtomAmode (StgLitArg lit) = returnFC (CLit lit) +getArgAmode (StgVarArg var) = getCAddrMode var +getArgAmode (StgLitArg lit) = returnFC (CLit lit) \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 45b21c1..5ed617d 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % %******************************************************** %* * @@ -10,48 +10,66 @@ \begin{code} #include "HsVersions.h" -module CgCase ( - cgCase, - saveVolatileVarsAndRegs +module CgCase ( cgCase, saveVolatileVarsAndRegs ) where - -- and to make the interface self-sufficient... - ) where +import Ubiq{-uitous-} +import CgLoop2 ( cgExpr, getPrimOpArgAmodes ) -import StgSyn import CgMonad +import StgSyn import AbsCSyn -import PrelInfo ( PrimOp(..), primOpCanTriggerGC - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, + magicIdPrimRep, getAmodeRep ) -import Type ( primRepFromType, getTyConDataCons, - getUniDataSpecTyCon, getUniDataSpecTyCon_maybe, - isEnumerationTyCon, - Type +import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes, + bindNewToReg, bindNewToTemp, + bindNewPrimToAmode, + rebindToAStack, rebindToBStack, + getCAddrModeAndInfo, getCAddrModeIfVolatile, + idInfoToAmode ) -import CgBindery -- all of it import CgCon ( buildDynCon, bindConArgs ) -import CgExpr ( cgExpr, getPrimOpArgAmodes ) import CgHeapery ( heapCheck ) -import CgRetConv -- lots of stuff -import CgStackery -- plenty +import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim, + ctrlReturnConvAlg, + DataReturnConvention(..), CtrlReturnConvention(..), + assignPrimOpResultRegs, + makePrimOpArgsRobust + ) +import CgStackery ( allocAStack, allocBStack ) import CgTailCall ( tailCallBusiness, performReturn ) -import CgUsages -- and even more -import CLabel -- bunches of things... -import ClosureInfo {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument, - layOutDynCon - )-} -import CostCentre ( useCurrentCostCentre, CostCentre ) -import Literal ( literalPrimRep ) -import Id ( getDataConTag, getIdPrimRep, fIRST_TAG, isDataCon, - toplevelishId, getInstantiatedDataConSig, - ConTag(..), DataCon(..) +import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot ) +import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel, + mkAltLabel, mkClosureLabel + ) +import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon ) +import CmdLineOpts ( opt_SccProfilingOn ) +import CostCentre ( useCurrentCostCentre ) +import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) ) +import Id ( idPrimRep, toplevelishId, + dataConTag, fIRST_TAG, ConTag(..), + isDataCon, DataCon(..), + idSetToList, GenId{-instance NamedThing,Eq-} ) -import Maybes ( catMaybes, Maybe(..) ) -import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, PrimRep(..) ) -import UniqSet -- ( uniqSetToList, UniqSet(..) ) -import Util +import Maybes ( catMaybes ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-} ) +import PrimOp ( primOpCanTriggerGC, PrimOp(..) ) +import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, + PrimRep(..) + ) +import TyCon ( isEnumerationTyCon ) +import Type ( typePrimRep, + getDataSpecTyCon, getDataSpecTyCon_maybe, + isEnumerationTyCon + ) +import Util ( sortLt, isIn, isn'tIn, zipEqual, + pprError, panic, assertPanic + ) + +getDataSpecTyCon = panic "CgCase.getDataSpecTyCon (ToDo)" +getDataSpecTyCon_maybe = panic "CgCase.getDataSpecTyCon_maybe (ToDo)" \end{code} \begin{code} @@ -193,18 +211,17 @@ cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts | otherwise -- *Can* trigger GC = getPrimOpArgAmodes op args `thenFC` \ arg_amodes -> ---NO: getIntSwitchChkrC `thenFC` \ isw_chkr -> -- Get amodes for the arguments and results, and assign to regs -- (Can-trigger-gc primops guarantee to have their (nonRobust) -- args in regs) let - op_result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op + op_result_regs = assignPrimOpResultRegs op op_result_amodes = map CReg op_result_regs (op_arg_amodes, liveness_mask, arg_assts) - = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes + = makePrimOpArgsRobust op arg_amodes liveness_arg = mkIntCLit liveness_mask in @@ -275,7 +292,7 @@ eliminate a heap check altogether. \begin{code} cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt) - = getAtomAmode v `thenFC` \ amode -> + = getArgAmode v `thenFC` \ amode -> cgPrimAltsGivenScrutinee NoGC amode alts deflt \end{code} @@ -288,7 +305,7 @@ 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 -> + getArgAmodes args `thenFC` \ arg_amodes -> -- Squish the environment nukeDeadBindings live_in_alts `thenC` @@ -368,7 +385,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used - -- 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 IntRep - (spec_tycon, _, _) = getUniDataSpecTyCon ty + (spec_tycon, _, _) = getDataSpecTyCon ty getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default) -- Default is either StgNoDefault or StgBindDefault with unused binder @@ -383,14 +400,14 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default) -- Sort alternatives into canonical order; there must be a complete -- set because there's no default case. sorted_alts = sortLt lt alts - (con1,_,_,_) `lt` (con2,_,_,_) = getDataConTag con1 < getDataConTag con2 + (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2 arg_amodes :: [CAddrMode] -- Turn them into amodes arg_amodes = concat (map mk_amodes sorted_alts) mk_amodes (con, args, use_mask, rhs) - = [ CTemp (getItsUnique arg) (getIdPrimRep arg) | arg <- args ] + = [ CTemp (getItsUnique arg) (idPrimRep arg) | arg <- args ] \end{code} The situation is simpler for primitive @@ -398,9 +415,7 @@ results, because there is only one! \begin{code} getPrimAppResultAmodes uniq (StgPrimAlts ty _ _) - = [CTemp uniq kind] - where - kind = primRepFromType ty + = [CTemp uniq (typePrimRep ty)] \end{code} @@ -425,7 +440,6 @@ cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt) = -- Generate the instruction to restore cost centre, if any restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore -> - getIntSwitchChkrC `thenFC` \ isw_chkr -> -- Generate sequel info for use downstream -- At the moment, we only do it if the type is vector-returnable. @@ -437,7 +451,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt) -- which is worse than having the alt code in the switch statement let - (spec_tycon, _, _) = getUniDataSpecTyCon ty + (spec_tycon, _, _) = getDataSpecTyCon ty use_labelled_alts = case ctrlReturnConvAlg spec_tycon of @@ -448,7 +462,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt) = if not use_labelled_alts then Nothing -- no semi-tagging info else - cgSemiTaggedAlts isw_chkr uniq alts deflt -- Just + cgSemiTaggedAlts uniq alts deflt -- Just in cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt `thenFC` \ (tagged_alt_absCs, deflt_absC) -> @@ -560,10 +574,9 @@ It's all pretty turgid anyway. \begin{code} cgAlgAlts gc_flag uniq restore_cc semi_tagging ty alts deflt@(StgBindDefault binder True{-used-} _) - = getIntSwitchChkrC `thenFC` \ isw_chkr -> - let + = let extra_branches :: [FCode (ConTag, AbstractC)] - extra_branches = catMaybes (map (mk_extra_branch isw_chkr) default_cons) + extra_branches = catMaybes (map mk_extra_branch default_cons) must_label_default = semi_tagging || not (null extra_branches) in @@ -575,14 +588,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging default_join_lbl = mkDefaultLabel uniq jump_instruction = CJump (CLbl default_join_lbl CodePtrRep) - (spec_tycon, _, spec_cons) - = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [ - -- ppr PprDebug uniq, - -- ppr PprDebug ty, - -- ppr PprShowAll binder - -- ]))) ( - getUniDataSpecTyCon ty - -- ) + (spec_tycon, _, spec_cons) = getDataSpecTyCon ty alt_cons = [ con | (con,_,_,_) <- alts ] @@ -596,18 +602,18 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging -- nothing to do. Otherwise, we have a special case for a nullary constructor, -- but in the general case we do an allocation and heap-check. - mk_extra_branch :: IntSwitchChecker -> DataCon -> (Maybe (FCode (ConTag, AbstractC))) + mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC))) - mk_extra_branch isw_chkr con + mk_extra_branch con = ASSERT(isDataCon con) - case dataReturnConvAlg isw_chkr con of + case dataReturnConvAlg con of ReturnInHeap -> Nothing ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c -> returnFC (tag, abs_c) ) where lf_info = mkConLFInfo con - tag = getDataConTag con + tag = dataConTag con closure_lbl = mkClosureLabel con -- alloc_code generates code to allocate constructor con, whose args are @@ -625,7 +631,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging absC jump_instruction ) where - zero_size reg = getPrimRepSize (kindFromMagicId reg) == 0 + zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0 \end{code} Now comes the general case @@ -698,16 +704,15 @@ cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs) in returnFC (tag, final_abs_c) where - tag = getDataConTag con + tag = dataConTag con lbl = mkAltLabel uniq tag cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code cgAlgAltRhs gc_flag con args use_mask rhs - = getIntSwitchChkrC `thenFC` \ isw_chkr -> - let + = let (live_regs, node_reqd) - = case (dataReturnConvAlg isw_chkr con) of + = case (dataReturnConvAlg con) of ReturnInHeap -> ([], True) ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False) -- Pick the live registers using the use_mask @@ -735,14 +740,13 @@ Turgid-but-non-monadic code to conjure up the required info from algebraic case alternatives for semi-tagging. \begin{code} -cgSemiTaggedAlts :: IntSwitchChecker - -> Unique +cgSemiTaggedAlts :: Unique -> [(Id, [Id], [Bool], StgExpr)] -> GenStgCaseDefault Id Id -> SemiTaggingStuff -cgSemiTaggedAlts isw_chkr uniq alts deflt - = Just (map (st_alt isw_chkr) alts, st_deflt deflt) +cgSemiTaggedAlts uniq alts deflt + = Just (map st_alt alts, st_deflt deflt) where st_deflt StgNoDefault = Nothing @@ -752,8 +756,8 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt mkDefaultLabel uniq) ) - st_alt isw_chkr (con, args, use_mask, _) - = case (dataReturnConvAlg isw_chkr con) of + st_alt (con, args, use_mask, _) + = case (dataReturnConvAlg con) of ReturnInHeap -> -- Ha! Nothing to do; Node already points to the thing @@ -767,7 +771,7 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt -- We have to load the live registers from the constructor -- pointed to by Node. let - (_, regs_w_offsets) = layOutDynCon con kindFromMagicId regs + (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs used_regs = selectByMask use_mask regs @@ -784,12 +788,12 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))], join_label)) where - con_tag = getDataConTag con + con_tag = dataConTag con join_label = mkAltLabel uniq con_tag move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC move_to_reg (reg, offset) - = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg)) + = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg)) \end{code} %************************************************************************ @@ -821,7 +825,7 @@ cgPrimAlts gc_flag uniq ty alts deflt NoGC -> CTemp uniq kind GCMayHappen -> CReg (dataReturnConvPrim kind) - kind = primRepFromType ty + kind = typePrimRep ty cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt @@ -892,7 +896,7 @@ saveVolatileVars :: StgLiveVars -- Vars which should be made safe -> FCode AbstractC -- Assignments to to the saves saveVolatileVars vars - = save_em (uniqSetToList vars) + = save_em (idSetToList vars) where save_em [] = returnFC AbsCNop @@ -978,7 +982,9 @@ saveCurrentCostCentre :: -- AbsCNop if not lexical CCs saveCurrentCostCentre - = isSwitchSetC SccProfilingOn `thenFC` \ doing_profiling -> + = let + doing_profiling = opt_SccProfilingOn + in if not doing_profiling then returnFC (Nothing, AbsCNop) else @@ -1047,9 +1053,9 @@ mkReturnVector uniq ty tagged_alt_absCs deflt_absC -- ) where - (spec_tycon,_,_) = case (getUniDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor + (spec_tycon,_,_) = case (getDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor Just xx -> xx - Nothing -> error ("ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: "++(ppShow 80 (ppr PprDebug ty))) + Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug ty) vtbl_label = mkVecTblLabel uniq ret_label = mkReturnPtLabel uniq diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index af31842..eeaf9da 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -12,31 +12,29 @@ with {\em closures} on the RHSs of let(rec)s. See also module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where -import StgSyn +import Ubiq{-uitous-} +import CgLoop2 ( cgExpr, cgSccExpr ) + import CgMonad import AbsCSyn +import StgSyn -import PrelInfo ( PrimOp(..), Name - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import Type ( isPrimType, isPrimTyCon, - getTauType, showTypeCategory, getTyConDataCons - ) -import CgBindery ( getCAddrMode, getAtomAmodes, - getCAddrModeAndInfo, - bindNewToNode, bindNewToAStack, bindNewToBStack, - bindNewToReg, bindArgsToRegs +import AbsCUtils ( mkAbstractCs, getAmodeRep ) +import CgBindery ( getCAddrMode, getArgAmodes, + getCAddrModeAndInfo, bindNewToNode, + bindNewToAStack, bindNewToBStack, + bindNewToReg, bindArgsToRegs, + stableAmodeIdInfo, heapIdInfo ) import CgCompInfo ( spARelToInt, spBRelToInt ) -import CgExpr ( cgExpr, cgSccExpr ) import CgUpdate ( pushUpdateFrame ) import CgHeapery ( allocDynClosure, heapCheck #ifdef GRAN - , heapCheckOnly, fetchAndReschedule -- HWL -#endif {- GRAN -} + , fetchAndReschedule -- HWL +#endif ) -import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask, +import CgRetConv ( mkLiveRegsMask, + ctrlReturnConvAlg, dataReturnConvAlg, CtrlReturnConvention(..), DataReturnConvention(..) ) import CgStackery ( getFinalStackHW, mkVirtStkOffsets, @@ -46,20 +44,37 @@ import CgUsages ( getVirtSps, setRealAndVirtualSps, getSpARelOffset, getSpBRelOffset, getHpRelOffset ) -import CLabel +import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, + mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel, + mkErrorStdEntryLabel, mkRednCountsLabel + ) import ClosureInfo -- lots and lots of stuff -import CostCentre -import Id ( idType, getIdPrimRep, isSysLocalId, myWrapperMaybe, - showId, getIdInfo, getIdStrictness, - getDataConTag +import CmdLineOpts ( opt_EmitArityChecks, opt_ForConcurrent, + opt_AsmTarget + ) +import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts, + noCostCentreAttached, costsAreSubsumed, + isCafCC, overheadCostCentre + ) +import HeapOffs ( VirtualHeapOffset(..) ) +import Id ( idType, idPrimRep, + showId, getIdStrictness, dataConTag, + emptyIdSet, + GenId{-instance Outputable-} ) -import IdInfo import ListSetOps ( minusList ) -import Maybes ( Maybe(..), maybeToBool ) -import PrimRep ( isFollowableRep ) -import UniqSet -import Unpretty -import Util +import Maybes ( maybeToBool ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} ) +import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr ) +import PrimRep ( isFollowableRep, PrimRep(..) ) +import TyCon ( isPrimTyCon, tyConDataCons ) +import Unpretty ( uppShow ) +import Util ( isIn, panic, pprPanic, assertPanic ) + +myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)" +showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)" +getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" \end{code} %******************************************************** @@ -171,7 +186,7 @@ cgRhsClosure binder cc binder_info fvs args body lf_info -- ToDo: check non-primitiveness (ASSERT) = ( -- LAY OUT THE OBJECT - getAtomAmodes std_thunk_payload `thenFC` \ amodes -> + getArgAmodes std_thunk_payload `thenFC` \ amodes -> let (closure_info, amodes_w_offsets) = layOutDynClosure binder getAmodeRep amodes lf_info @@ -226,7 +241,7 @@ cgRhsClosure binder cc binder_info fvs args body lf_info amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details] - get_kind (id, amode_and_info) = getIdPrimRep id + get_kind (id, amode_and_info) = idPrimRep id in -- BUILD ITS INFO TABLE AND CODE forkClosureBody ( @@ -302,7 +317,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info -- 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 (StgVarArg fun) (map StgVarArg args) emptyUniqSet + vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet -- Empty live vars arg_ids_w_info = [(name,mkLFArgument) | name <- args] @@ -320,7 +335,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info -- let x = f p q -- x isn't top level! -- in ... - get_kind (id, info) = getIdPrimRep id + get_kind (id, info) = idPrimRep id payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)] (closure_info, payload_bind_details) = layOutDynClosure @@ -390,11 +405,10 @@ closureCodeBody binder_info closure_info cc [] body #endif getAbsC body_code `thenFC` \ body_absC -> moduleName `thenFC` \ mod_name -> - getIntSwitchChkrC `thenFC` \ isw_chkr -> absC (CClosureInfoAndCode closure_info body_absC Nothing stdUpd (cl_descr mod_name) - (dataConLiveness isw_chkr closure_info)) + (dataConLiveness closure_info)) where cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body @@ -418,22 +432,19 @@ Node points to closure is available. -- HWL \begin{code} closureCodeBody binder_info closure_info cc all_args body = getEntryConvention id lf_info - (map getIdPrimRep all_args) `thenFC` \ entry_conv -> - - isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks -> - - isSwitchSetC ForConcurrent `thenFC` \ is_concurrent -> - - isStringSwitchSetC AsmTarget `thenFC` \ native_code -> - + (map idPrimRep all_args) `thenFC` \ entry_conv -> let + do_arity_chks = opt_EmitArityChecks + is_concurrent = opt_ForConcurrent + native_code = opt_AsmTarget + stg_arity = length all_args -- 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 0 0 -- Initial virtual SpA, SpB - getIdPrimRep + idPrimRep all_args -- Arg mapping for the fast entry point; as many args as poss in @@ -450,7 +461,7 @@ closureCodeBody binder_info closure_info cc all_args body (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets) = mkVirtStkOffsets 0 0 -- Initial virtual SpA, SpB - getIdPrimRep + idPrimRep stk_args -- HWL; Note: empty list of live regs in slow entry code @@ -531,7 +542,6 @@ closureCodeBody binder_info closure_info cc all_args body `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) @@ -539,7 +549,7 @@ closureCodeBody binder_info closure_info cc all_args body if info_table_needed then CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c) stdUpd (cl_descr mod_name) - (dataConLiveness isw_chkr closure_info) + (dataConLiveness closure_info) else CCodeBlock fast_label fast_abs_c ) @@ -665,18 +675,22 @@ argSatisfactionCheck closure_info args if (isFollowableRep (getAmodeRep last_amode)) then getSpARelOffset 0 `thenFC` \ (SpARel spA off) -> + let + lit = mkIntCLit (spARelToInt spA off) + in if node_points then - absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt spA off)]) + absC (CMacroStmt ARGS_CHK_A [lit]) else - absC (CMacroStmt ARGS_CHK_A_LOAD_NODE - [mkIntCLit (spARelToInt spA off), set_Node_to_this]) + absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [lit, set_Node_to_this]) else - getSpBRelOffset 0 `thenFC` \ b_rel_offset -> + getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) -> + let + lit = mkIntCLit (spBRelToInt spB off) + in if node_points then - absC (CMacroStmt ARGS_CHK_B [mkIntCLit (spBRelToInt b_rel_offset)]) + absC (CMacroStmt ARGS_CHK_B [lit]) else - absC (CMacroStmt ARGS_CHK_B_LOAD_NODE - [mkIntCLit (spBRelToInt b_rel_offset), set_Node_to_this]) + absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [lit, set_Node_to_this]) where -- We must tell the arg-satis macro whether Node is pointing to -- the closure or not. If it isn't so pointing, then we give to @@ -780,7 +794,7 @@ stackCheck closure_info regs node_reqd code ) where all_regs = if node_reqd then node:regs else regs - liveness_mask = mkLiveRegsBitMask all_regs + liveness_mask = mkLiveRegsMask all_regs returns_prim_type = closureReturnsUnboxedType closure_info \end{code} @@ -817,8 +831,7 @@ setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks setupUpdate closure_info code = if (closureUpdReqd closure_info) then link_caf_if_needed `thenFC` \ update_closure -> - getIntSwitchChkrC `thenFC` \ isw_chkr -> - pushUpdateFrame update_closure (vector isw_chkr) code + pushUpdateFrame update_closure vector code else profCtrC SLIT("UPDF_OMITTED") [] `thenC` code @@ -849,7 +862,7 @@ setupUpdate closure_info code closure_label = mkClosureLabel (closureId closure_info) - vector isw_chkr + vector = case (closureType closure_info) of Nothing -> CReg StdUpdRetVecReg Just (spec_tycon, _, spec_datacons) -> @@ -857,9 +870,9 @@ setupUpdate closure_info code UnvectoredReturn 1 -> let spec_data_con = head spec_datacons - only_tag = getDataConTag spec_data_con + only_tag = dataConTag spec_data_con - direct = case (dataReturnConvAlg isw_chkr spec_data_con) of + direct = case (dataReturnConvAlg spec_data_con) of ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag @@ -893,8 +906,8 @@ closureDescription :: FAST_STRING -- Module -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.lhs with a description generated from the data constructor -closureDescription mod_name name args body = - uppShow 0 (prettyToUn ( +closureDescription mod_name name args body + = uppShow 0 (prettyToUn ( ppBesides [ppChar '<', ppPStr mod_name, ppChar '.', diff --git a/ghc/compiler/codeGen/CgCompInfo.lhs b/ghc/compiler/codeGen/CgCompInfo.lhs index 4b52bf0..9b14dcd 100644 --- a/ghc/compiler/codeGen/CgCompInfo.lhs +++ b/ghc/compiler/codeGen/CgCompInfo.lhs @@ -141,6 +141,9 @@ mAX_INTLIKE = MAX_INTLIKE \begin{code} -- THESE ARE DIRECTION SENSITIVE! +spARelToInt :: Int{-VirtualSpAOffset-} -> Int{-VirtualSpAOffset-} -> Int +spBRelToInt :: Int{-VirtualSpBOffset-} -> Int{-VirtualSpBOffset-} -> Int + spARelToInt spA off = spA - off -- equiv to: AREL(spA - off) spBRelToInt spB off = off - spB -- equiv to: BREL(spB - off) \end{code} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 8201335..6c378a9 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP Project, Glasgow University, 1992-1995 +% (c) The GRASP Project, Glasgow University, 1992-1996 % \section[CgCon]{Code generation for constructors} @@ -11,55 +11,50 @@ with {\em constructors} on the RHSs of let(rec)s. See also #include "HsVersions.h" module CgCon ( - -- it's all exported, actually... cgTopRhsCon, buildDynCon, bindConArgs, cgReturnDataCon - - -- and to make the interface self-sufficient... ) where -import StgSyn +import Ubiq{-uitous-} + import CgMonad import AbsCSyn +import StgSyn -import Type ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar, - TyCon, Class, Type - ) -import CgBindery ( getAtomAmode, getAtomAmodes, bindNewToNode, - bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode +import AbsCUtils ( mkAbstractCs, getAmodeRep ) +import CgBindery ( getArgAmodes, bindNewToNode, + bindArgsToRegs, newTempAmodeAndIdInfo, + idInfoToAmode, stableAmodeIdInfo, + heapIdInfo ) import CgClosure ( cgTopRhsClosure ) -import CgHeapery ( allocDynClosure, heapCheck -#ifdef GRAN - , fetchAndReschedule -- HWL -#endif {- GRAN -} - ) import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE ) - -import CgRetConv ( dataReturnConvAlg, mkLiveRegsBitMask, - CtrlReturnConvention(..), DataReturnConvention(..) - ) +import CgHeapery ( allocDynClosure ) +import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) ) import CgTailCall ( performReturn, mkStaticAlgReturnCode ) -import CgUsages ( getHpRelOffset ) -import CLabel ( CLabel, mkClosureLabel, mkInfoTableLabel, +import CLabel ( mkClosureLabel, mkInfoTableLabel, mkPhantomInfoTableLabel, mkConEntryLabel, mkStdEntryLabel ) -import ClosureInfo -- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas - {-( mkConLFInfo, mkLFArgument, closureLFInfo, +import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument, layOutDynCon, layOutDynClosure, - layOutStaticClosure, UpdateFlag(..), - mkClosureLFInfo, layOutStaticNoFVClosure - )-} -import Id ( getIdPrimRep, getDataConTag, getDataConTyCon, - isDataCon, fIRST_TAG, DataCon(..), ConTag(..) + layOutStaticClosure + ) +import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre, + dontCareCostCentre ) -import Maybes ( maybeToBool, Maybe(..) ) -import PrimRep ( PrimRep(..), isFloatingRep, getPrimRepSize ) -import CostCentre -import UniqSet -- ( emptyUniqSet, UniqSet(..) ) -import Util +import Id ( idPrimRep, dataConTag, dataConTyCon, + isDataCon, DataCon(..), + emptyIdSet + ) +import Literal ( Literal(..) ) +import Maybes ( maybeToBool ) +import PrimRep ( isFloatingRep, PrimRep(..) ) +import Util ( isIn, zipWithEqual, panic, assertPanic ) + +maybeCharLikeTyCon = panic "CgCon.maybeCharLikeTyCon (ToDo)" +maybeIntLikeTyCon = panic "CgCon.maybeIntLikeTyCon (ToDo)" \end{code} %************************************************************************ @@ -71,7 +66,7 @@ import Util \begin{code} cgTopRhsCon :: Id -- Name of thing bound to this RHS -> DataCon -- Id - -> [StgArg] -- Args + -> [StgArg] -- Args -> Bool -- All zero-size args (see buildDynCon) -> FCode (Id, CgIdInfo) \end{code} @@ -130,7 +125,7 @@ cgTopRhsCon name con args all_zero_size_args || any isLitLitArg args = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info where - body = StgCon con args emptyUniqSet{-emptyLiveVarSet-} + body = StgCon con args emptyIdSet{-emptyLiveVarSet-} lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body \end{code} @@ -142,7 +137,7 @@ cgTopRhsCon name con args all_zero_size_args ASSERT(isDataCon con) -- LAY IT OUT - getAtomAmodes args `thenFC` \ amodes -> + getArgAmodes args `thenFC` \ amodes -> let (closure_info, amodes_w_offsets) @@ -163,13 +158,13 @@ cgTopRhsCon name con args all_zero_size_args -- RETURN returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info) where - con_tycon = getDataConTyCon con - lf_info = mkConLFInfo con + con_tycon = dataConTyCon con + lf_info = mkConLFInfo con - closure_label = mkClosureLabel name + closure_label = mkClosureLabel name info_label = mkInfoTableLabel con - con_entry_label = mkConEntryLabel con - entry_label = mkStdEntryLabel name + con_entry_label = mkConEntryLabel con + entry_label = mkStdEntryLabel name \end{code} The general case is: @@ -314,10 +309,10 @@ buildDynCon binder cc con [arg_amode] all_zero_size_args@False = ASSERT(isDataCon con) returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con)) where - tycon = getDataConTyCon con + tycon = dataConTyCon con (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 (CLit (MachInt val _)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE in_range_int_lit other_amode = False \end{code} @@ -357,13 +352,11 @@ found a $con$. bindConArgs :: DataCon -> [Id] -> Code bindConArgs con args = ASSERT(isDataCon con) - getIntSwitchChkrC `thenFC` \ isw_chkr -> - - case (dataReturnConvAlg isw_chkr con) of + case (dataReturnConvAlg con) of ReturnInRegs rs -> bindArgsToRegs args rs ReturnInHeap -> let - (_, args_w_offsets) = layOutDynCon con getIdPrimRep args + (_, args_w_offsets) = layOutDynCon con idPrimRep args in mapCs bind_arg args_w_offsets where @@ -385,13 +378,12 @@ cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> StgLiveVars -> Code cgReturnDataCon con amodes all_zero_size_args live_vars = ASSERT(isDataCon con) - getIntSwitchChkrC `thenFC` \ isw_chkr -> getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) -> case sequel of CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl)))) - | not (getDataConTag con `is_elem` map fst alts) + | not (dataConTag con `is_elem` map fst alts) -> -- Special case! We're returning a constructor to the default case -- of an enclosing case. For example: @@ -423,7 +415,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars -- Ignore the sequel: we've already looked at it above other_sequel -> -- The usual case - case (dataReturnConvAlg isw_chkr con) of + case (dataReturnConvAlg con) of ReturnInHeap -> -- BUILD THE OBJECT IN THE HEAP diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 79dd48e..4252890 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -1,59 +1,52 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[CgConTbls]{Info tables and update bits for constructors} \begin{code} #include "HsVersions.h" -module CgConTbls ( - genStaticConBits, +module CgConTbls ( genStaticConBits ) where - -- and to complete the interface... - TCE(..), UniqFM, CompilationInfo, AbstractC - ) where - -import Pretty -- ToDo: rm (debugging) -import Outputable +import Ubiq{-uitous-} import AbsCSyn import CgMonad -import Type ( getTyConDataCons, primRepFromType, - maybeIntLikeTyCon, mkSpecTyCon, - TyVarTemplate, TyCon, Class, - TauType(..), Type, ThetaType(..) - ) +import AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep ) +import CgCompInfo ( uF_UPDATEE ) import CgHeapery ( heapCheck, allocDynClosure ) -import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg, - mkLiveRegsBitMask, +import CgRetConv ( mkLiveRegsMask, + dataReturnConvAlg, ctrlReturnConvAlg, CtrlReturnConvention(..), DataReturnConvention(..) ) import CgTailCall ( performReturn, mkStaticAlgReturnCode ) import CgUsages ( getHpRelOffset ) -import CLabel ( mkConEntryLabel, mkStaticConEntryLabel, - mkClosureLabel, - mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel, - mkStdUpdVecTblLabel, CLabel +import CLabel ( mkConEntryLabel, mkClosureLabel, + mkConUpdCodePtrVecLabel, + mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel ) import ClosureInfo ( layOutStaticClosure, layOutDynCon, - closureSizeWithoutFixedHdr, closurePtrsSize, - fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure, + layOutPhantomClosure, closurePtrsSize, + fitsMinUpdSize, mkConLFInfo, infoTableLabelFromCI, dataConLiveness ) -import FiniteMap -import Id ( getDataConTag, getDataConSig, getDataConTyCon, - mkSameSpecCon, - getDataConArity, fIRST_TAG, ConTag(..), - DataCon(..) +import CostCentre ( dontCareCostCentre ) +import FiniteMap ( fmToList ) +import HeapOffs ( zeroOff, VirtualHeapOffset(..) ) +import Id ( dataConTag, dataConSig, + dataConArity, fIRST_TAG, + emptyIdSet, + GenId{-instance NamedThing-} ) -import CgCompInfo ( uF_UPDATEE ) -import Maybes ( maybeToBool, Maybe(..) ) -import PrimRep ( getPrimRepSize, retPrimRepSize ) -import CostCentre -import UniqSet -- ( emptyUniqSet, UniqSet(..) ) -import Util +import PrimRep ( getPrimRepSize, PrimRep(..) ) +import TyCon ( tyConDataCons, mkSpecTyCon ) +import Type ( typePrimRep ) +import Util ( panic ) + +maybeIntLikeTyCon = panic "CgConTbls.maybeIntLikeTyCon (ToDo)" +mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)" \end{code} For every constructor we generate the following info tables: @@ -139,7 +132,7 @@ genStaticConBits comp_info gen_tycons tycon_specs `mkAbsCStmts` maybe_tycon_vtbl where - data_cons = getTyConDataCons tycon + data_cons = tyConDataCons tycon tycon_upd_label = mkStdUpdVecTblLabel tycon maybe_tycon_vtbl = @@ -157,7 +150,7 @@ genStaticConBits comp_info gen_tycons tycon_specs `mkAbsCStmts` maybe_spec_tycon_vtbl where - data_cons = getTyConDataCons tycon + data_cons = tyConDataCons tycon spec_tycon = mkSpecTyCon tycon ty_maybes spec_data_cons = map (mkSameSpecCon ty_maybes) data_cons @@ -174,15 +167,12 @@ genStaticConBits comp_info gen_tycons tycon_specs ------------------ mk_upd_label tycon con = CLbl - (case (dataReturnConvAlg isw_chkr con) of + (case (dataReturnConvAlg con) of ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep where - tag = getDataConTag con - - ------------------ - (MkCompInfo sw_chkr isw_chkr _) = comp_info + tag = dataConTag con \end{code} %************************************************************************ @@ -197,7 +187,7 @@ static closure, for a constructor. \begin{code} genConInfo :: CompilationInfo -> TyCon -> Id -> AbstractC -genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con +genConInfo comp_info tycon data_con = mkAbstractCs [ CSplitMarker, inregs_upd_maybe, @@ -206,12 +196,12 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con closure_maybe] -- Order of things is to reduce forward references where - (closure_info, body_code) = mkConCodeAndInfo isw_chkr data_con + (closure_info, body_code) = mkConCodeAndInfo data_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 primRepFromType arg_tys (mkConLFInfo data_con) + (static_ci,_) = layOutStaticClosure data_con typePrimRep arg_tys (mkConLFInfo data_con) body = (initC comp_info ( profCtrC SLIT("ENT_CON") [CReg node] `thenC` @@ -222,16 +212,16 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con closure_code = CClosureInfoAndCode closure_info body Nothing stdUpd con_descr - (dataConLiveness isw_chkr closure_info) + (dataConLiveness closure_info) static_code = CClosureInfoAndCode static_ci body Nothing stdUpd con_descr - (dataConLiveness isw_chkr static_ci) + (dataConLiveness static_ci) inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep - tag = getDataConTag data_con + tag = dataConTag data_con cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs @@ -247,42 +237,41 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con cost_centre [{-No args! A slight lie for constrs with VoidRep args-}] - zero_size arg_ty = getPrimRepSize (primRepFromType arg_ty) == 0 + zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0 - (_,_,arg_tys,_) = getDataConSig data_con - con_arity = getDataConArity data_con + (_,_,arg_tys,_) = dataConSig data_con + con_arity = dataConArity data_con entry_label = mkConEntryLabel data_con closure_label = mkClosureLabel data_con \end{code} \begin{code} -mkConCodeAndInfo :: IntSwitchChecker - -> Id -- Data constructor +mkConCodeAndInfo :: Id -- Data constructor -> (ClosureInfo, Code) -- The info table -mkConCodeAndInfo isw_chkr con - = case (dataReturnConvAlg isw_chkr con) of +mkConCodeAndInfo con + = case (dataReturnConvAlg con) of ReturnInRegs regs -> let (closure_info, regs_w_offsets) - = layOutDynCon con kindFromMagicId regs + = layOutDynCon con magicIdPrimRep regs body_code = profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC` performReturn (mkAbstractCs (map move_to_reg regs_w_offsets)) (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-}) - emptyUniqSet{-no live vars-} + emptyIdSet{-no live vars-} in (closure_info, body_code) ReturnInHeap -> let - (_, _, arg_tys, _) = getDataConSig con + (_, _, arg_tys, _) = dataConSig con (closure_info, arg_things) - = layOutDynCon con primRepFromType arg_tys + = layOutDynCon con typePrimRep arg_tys body_code = -- NB: We don't set CC when entering data (WDP 94/06) @@ -290,14 +279,14 @@ mkConCodeAndInfo isw_chkr con performReturn AbsCNop -- Ptr to thing already in Node (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-}) - emptyUniqSet{-no live vars-} + emptyIdSet{-no live vars-} in (closure_info, body_code) where move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC move_to_reg (reg, offset) - = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg)) + = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg)) \end{code} %************************************************************************ @@ -312,8 +301,8 @@ Generate the "phantom" info table and update code, iff the constructor returns i genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC -genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con - = case (dataReturnConvAlg isw_chkr data_con) of +genPhantomUpdInfo comp_info tycon data_con + = case (dataReturnConvAlg data_con) of ReturnInHeap -> AbsCNop -- No need for a phantom update @@ -321,19 +310,19 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con let phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing upd_code con_descr - (dataConLiveness isw_chkr phantom_ci) + (dataConLiveness phantom_ci) phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con) con_descr = _UNPK_ (getOccurrenceName data_con) - con_arity = getDataConArity data_con + con_arity = dataConArity data_con upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return) upd_label = mkConUpdCodePtrVecLabel tycon tag - tag = getDataConTag data_con + tag = dataConTag data_con - updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrRep + updatee = CVal (SpBRel 0 (- uF_UPDATEE)) PtrRep perform_return = mkAbstractCs [ @@ -352,7 +341,7 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con blame_cc = use_cc -- who to blame for allocation do_move (reg, virt_offset) = - CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg) + CAssign (CVal (NodeRel virt_offset) (magicIdPrimRep reg)) (CReg reg) -- Code for building a new constructor in place over the updatee @@ -402,9 +391,9 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con CAssign (CReg infoptr) (CLbl info_label DataPtrRep) ]) - (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs + (closure_info, regs_w_offsets) = layOutDynCon data_con magicIdPrimRep regs info_label = infoTableLabelFromCI closure_info - liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs)) + liveness_mask = mkIntCLit (mkLiveRegsMask (node:regs)) build_closure = if fitsMinUpdSize closure_info then diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 4713767..6fed112 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -10,40 +10,41 @@ \begin{code} #include "HsVersions.h" -module CgExpr ( - cgExpr, cgSccExpr, getPrimOpArgAmodes +module CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) where - -- and to make the interface self-sufficient... - ) where +import Ubiq{-uitous-} +import CgLoop2 -- here for paranoia-checking import StgSyn import CgMonad import AbsCSyn -import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..), - primOpHeapReq, getPrimOpResultInfo, PrimRep, - primOpCanTriggerGC - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import Type ( isPrimType, getTyConDataCons ) -import CLabel ( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel ) -import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo ) -import CgBindery ( getAtomAmodes ) +import AbsCUtils ( mkAbsCStmts, mkAbstractCs ) +import CgBindery ( getArgAmodes ) import CgCase ( cgCase, saveVolatileVarsAndRegs ) import CgClosure ( cgRhsClosure ) import CgCon ( buildDynCon, cgReturnDataCon ) import CgHeapery ( allocHeap ) import CgLetNoEscape ( cgLetNoEscapeClosure ) -import CgRetConv -- various things... -import CgTailCall ( cgTailCall, performReturn, mkDynamicAlgReturnCode, - mkPrimReturnCode +import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg, + DataReturnConvention(..), CtrlReturnConvention(..), + assignPrimOpResultRegs, makePrimOpArgsRobust + ) +import CgTailCall ( cgTailCall, performReturn, + mkDynamicAlgReturnCode, mkPrimReturnCode + ) +import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel ) +import ClosureInfo ( mkClosureLFInfo ) +import CostCentre ( setToAbleCostCentre, isDupdCC ) +import HeapOffs ( VirtualSpBOffset(..) ) +import Id ( mkIdSet, unionIdSets, GenId{-instance Outputable-} ) +import PprStyle ( PprStyle(..) ) +import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..), + getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) ) -import CostCentre ( setToAbleCostCentre, isDupdCC, CostCentre ) -import Maybes ( Maybe(..) ) -import PrimRep ( getPrimRepSize ) -import UniqSet -import Util +import PrimRep ( getPrimRepSize, PrimRep(..) ) +import TyCon ( tyConDataCons ) +import Util ( panic, pprPanic ) \end{code} This module provides the support code for @StgToAbstractC@ to deal @@ -77,7 +78,7 @@ cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars \begin{code} cgExpr (StgCon con args live_vars) - = getAtomAmodes args `thenFC` \ amodes -> + = getArgAmodes args `thenFC` \ amodes -> cgReturnDataCon con amodes (all zero_size args) live_vars where zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 @@ -93,10 +94,9 @@ Here is where we insert real live machine instructions. \begin{code} cgExpr x@(StgPrim op args live_vars) - = getIntSwitchChkrC `thenFC` \ isw_chkr -> - getPrimOpArgAmodes op args `thenFC` \ arg_amodes -> + = getPrimOpArgAmodes op args `thenFC` \ arg_amodes -> let - result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op + result_regs = assignPrimOpResultRegs op result_amodes = map CReg result_regs may_gc = primOpCanTriggerGC op dyn_tag = head result_amodes @@ -108,7 +108,7 @@ cgExpr x@(StgPrim op args live_vars) -- (Can-trigger-gc primops guarantee to have their args in regs) let (arg_robust_amodes, liveness_mask, arg_assts) - = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes + = makePrimOpArgsRobust op arg_amodes liveness_arg = mkIntCLit liveness_mask in @@ -172,10 +172,10 @@ cgExpr x@(StgPrim op args live_vars) vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep) dyn_tag DataPtrRep - data_con = head (getTyConDataCons tycon) + data_con = head (tyConDataCons tycon) (dir_lbl, num_of_fields) - = case (dataReturnConvAlg fake_isw_chkr data_con) of + = case (dataReturnConvAlg data_con) of ReturnInRegs rs -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep, mkIntCLit (length rs)) -- for ticky-ticky only @@ -184,8 +184,6 @@ cgExpr x@(StgPrim op args live_vars) -> pprPanic "CgExpr: can't return prim in heap:" (ppr PprDebug data_con) -- Never used, and no point in generating -- the code for it! - - fake_isw_chkr x = Nothing where -- for all PrimOps except ccalls, we pin the liveness info -- on as the first "argument" @@ -314,7 +312,7 @@ 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) - = getAtomAmodes args `thenFC` \ amodes -> + = getArgAmodes args `thenFC` \ amodes -> buildDynCon name maybe_cc con amodes (all zero_size args) `thenFC` \ idinfo -> returnFC (name, idinfo) @@ -344,7 +342,7 @@ cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs) where -- We add the binders to the live-in-rhss set so that we don't -- delete the bindings for the binder from the environment! - full_live_in_rhss = live_in_rhss `unionUniqSets` (mkUniqSet [b | (b,r) <- pairs]) + full_live_in_rhss = live_in_rhss `unionIdSets` (mkIdSet [b | (b,r) <- pairs]) cgLetNoEscapeRhs :: StgLiveVars -- Live in rhss @@ -386,10 +384,9 @@ Main current use: allocating SynchVars. \begin{code} getPrimOpArgAmodes op args - = getAtomAmodes args `thenFC` \ arg_amodes -> + = getArgAmodes args `thenFC` \ arg_amodes -> case primOpHeapReq op of - FixedHeapRequired size -> allocHeap size `thenFC` \ amode -> returnFC (amode : arg_amodes) diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 98aed04..798c6ba 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[CgHeapery]{Heap management functions} @@ -8,30 +8,31 @@ module CgHeapery ( heapCheck, - allocHeap, allocDynClosure, + allocHeap, allocDynClosure #ifdef GRAN -- new for GrAnSim HWL - heapCheckOnly, fetchAndReschedule, + , heapCheckOnly, fetchAndReschedule #endif {- GRAN -} - - -- and to make the interface self-sufficient... - AbstractC, CAddrMode, HeapOffset, - CgState, ClosureInfo, Id ) where +import Ubiq{-uitous-} + import AbsCSyn import CgMonad -import CgRetConv ( mkLiveRegsBitMask ) +import AbsCUtils ( mkAbstractCs, getAmodeRep ) +import CgRetConv ( mkLiveRegsMask ) import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp, initHeapUsage ) -import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, slopSize, - layOutDynClosure, - allocProfilingMsg, closureKind +import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, + slopSize, allocProfilingMsg, closureKind + ) +import HeapOffs ( isZeroOff, addOff, intOff, + VirtualHeapOffset(..) ) -import Util +import PrimRep ( PrimRep(..) ) \end{code} %************************************************************************ @@ -70,7 +71,7 @@ heapCheck regs node_reqd code -- at once or not. where all_regs = if node_reqd then node:regs else regs - liveness_mask = mkLiveRegsBitMask all_regs + liveness_mask = mkLiveRegsMask all_regs checking_code = CMacroStmt HEAP_CHK [ mkIntCLit liveness_mask, @@ -149,7 +150,7 @@ heapCheck' do_context_switch regs node_reqd code -- at once or not. where all_regs = if node_reqd then node:regs else regs - liveness_mask = mkLiveRegsBitMask all_regs + liveness_mask = mkLiveRegsMask all_regs maybe_context_switch = if do_context_switch then context_switch_code @@ -177,7 +178,7 @@ fetchAndReschedule regs node_reqd = else absC AbsCNop where all_regs = if node_reqd then node:regs else regs - liveness_mask = mkLiveRegsBitMask all_regs + liveness_mask = mkLiveRegsMask all_regs reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [ mkIntCLit liveness_mask, diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index 5480e93..f59ef4e 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -12,20 +12,24 @@ module CgLetNoEscape ( cgLetNoEscapeClosure ) where +import Ubiq{-uitious-} +import CgLoop2 ( cgExpr ) + import StgSyn import CgMonad import AbsCSyn -import CgBindery -- various things -import CgExpr ( cgExpr ) +import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs, + bindNewToAStack, bindNewToBStack + ) import CgHeapery ( heapCheck ) import CgRetConv ( assignRegs ) import CgStackery ( mkVirtStkOffsets ) import CgUsages ( setRealAndVirtualSps, getVirtSps ) -import CLabel ( mkStdEntryLabel ) +import CLabel ( mkStdEntryLabel ) import ClosureInfo ( mkLFLetNoEscape ) -import Id ( getIdPrimRep ) -import Util +import HeapOffs ( VirtualSpBOffset(..) ) +import Id ( idPrimRep ) \end{code} %************************************************************************ @@ -164,10 +168,9 @@ cgLetNoEscapeBody :: [Id] -- Args cgLetNoEscapeBody all_args rhs = getVirtSps `thenFC` \ (vA, vB) -> - getIntSwitchChkrC `thenFC` \ isw_chkr -> let - arg_kinds = map getIdPrimRep all_args - (arg_regs, _) = assignRegs isw_chkr [{-nothing live-}] arg_kinds + arg_kinds = map idPrimRep all_args + (arg_regs, _) = assignRegs [{-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 @@ -175,7 +178,7 @@ cgLetNoEscapeBody all_args rhs (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets) = mkVirtStkOffsets vA vB -- Initial virtual SpA, SpB - getIdPrimRep + idPrimRep stk_args in diff --git a/ghc/compiler/codeGen/CgLoop1.lhi b/ghc/compiler/codeGen/CgLoop1.lhi new file mode 100644 index 0000000..ef8dd2d --- /dev/null +++ b/ghc/compiler/codeGen/CgLoop1.lhi @@ -0,0 +1,35 @@ +\begin{code} +interface CgLoop1 where +import PreludeStdIO ( Maybe ) + +import CgBindery ( CgBindings(..), CgIdInfo(..), + VolatileLoc, StableLoc, + nukeVolatileBinds, + maybeAStkLoc, maybeBStkLoc + ) +import CgUsages ( getSpBRelOffset ) + +import AbsCSyn ( RegRelative ) +import CgMonad ( FCode(..) ) +import ClosureInfo ( LambdaFormInfo ) +import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) ) +import Id ( IdEnv(..), Id(..) ) + +type CgBindings = IdEnv CgIdInfo + +data CgIdInfo + = MkCgIdInfo Id -- Id that this is the info for + VolatileLoc + StableLoc + LambdaFormInfo + +data VolatileLoc +data StableLoc +data LambdaFormInfo + +nukeVolatileBinds :: CgBindings -> CgBindings +maybeAStkLoc :: StableLoc -> Maybe VirtualSpAOffset +maybeBStkLoc :: StableLoc -> Maybe VirtualSpBOffset + +getSpBRelOffset :: VirtualSpBOffset -> FCode RegRelative +\end{code} diff --git a/ghc/compiler/codeGen/CgLoop2.lhi b/ghc/compiler/codeGen/CgLoop2.lhi new file mode 100644 index 0000000..feda847 --- /dev/null +++ b/ghc/compiler/codeGen/CgLoop2.lhi @@ -0,0 +1,15 @@ +Break loops caused by cgExpr and getPrimOpArgAmodes. +\begin{code} +interface CgLoop2 where + +import CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) + +import AbsCSyn ( CAddrMode ) +import CgMonad ( Code(..), FCode(..) ) +import PrimOp ( PrimOp ) +import StgSyn ( StgExpr(..), StgArg(..) ) + +cgExpr :: StgExpr -> Code +cgSccExpr :: StgExpr -> Code +getPrimOpArgAmodes :: PrimOp -> [StgArg] -> FCode [CAddrMode] +\end{code} diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 65c4217..428d6f6 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[CgMonad]{The code generation monad} @@ -34,8 +34,6 @@ module CgMonad ( -- addFreeASlots, -- no need to export it addFreeBSlots, -- ToDo: Belong elsewhere - isSwitchSetC, isStringSwitchSetC, getIntSwitchChkrC, - noBlackHolingFlag, profCtrC, @@ -45,31 +43,35 @@ module CgMonad ( sequelToAmode, -- out of general friendliness, we also export ... - CgBindings(..), CgInfoDownwards(..), CgState(..), -- non-abstract - CgIdInfo, -- abstract - CompilationInfo(..), IntSwitchChecker(..), - - stableAmodeIdInfo, heapIdInfo - - -- and to make the interface self-sufficient... + CompilationInfo(..) ) where +import Ubiq{-uitous-} +import CgLoop1 -- stuff from CgBindery and CgUsages + import AbsCSyn -import Type ( primRepFromType, Type - IF_ATTACK_PRAGMAS(COMMA cmpUniType) +import AbsCUtils ( mkAbsCStmts ) +import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling, + opt_OmitBlackHoling + ) +import HeapOffs ( maxOff, + VirtualSpAOffset(..), VirtualSpBOffset(..) + ) +import Id ( idType, + nullIdEnv, mkIdEnv, addOneToIdEnv, + modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv(..), + ConTag(..), GenId{-instance Outputable-} ) -import CgBindery -import CgUsages ( getSpBRelOffset ) -import CmdLineOpts ( GlobalSwitch(..) ) -import Id ( idType, ConTag(..), DataCon(..) ) -import Maybes ( catMaybes, maybeToBool, Maybe(..) ) -import Pretty -- debugging only? -import PrimRep ( getPrimRepSize, retPrimRepSize ) -import UniqSet -- ( elementOfUniqSet, UniqSet(..) ) -import CostCentre -- profiling stuff -import StgSyn ( StgArg(..), StgLiveVars(..) ) -import Util +import Maybes ( maybeToBool ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-} ) +import Pretty ( ppAboves, ppCat, ppStr ) +import PrimRep ( getPrimRepSize, PrimRep(..) ) +import StgSyn ( StgLiveVars(..) ) +import Type ( typePrimRep ) +import UniqSet ( elementOfUniqSet ) +import Util ( sortLt, panic, pprPanic ) infixr 9 `thenC` -- Right-associative! infixr 9 `thenFC` @@ -108,43 +110,42 @@ data CgState CgStksAndHeapUsage \end{code} -@EndOfBlockInfo@ tells what to do at the end of this block of code -or, if the expression is a @case@, what to do at the end of each alternative. +@EndOfBlockInfo@ tells what to do at the end of this block of code or, +if the expression is a @case@, what to do at the end of each +alternative. \begin{code} data EndOfBlockInfo = EndOfBlockInfo - VirtualSpAOffset -- Args SpA: trim the A stack to this point at a return; - -- push arguments starting just above this point on - -- a tail call. - - -- This is therefore the A-stk ptr as seen - -- by a case alternative. - - -- 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 - -- top of the continuation's stack! - - VirtualSpBOffset -- Args SpB: Very similar to Args SpA. - - -- Two main differences: - -- 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 - -- points to the top word of the return address. - -- - -- 2. It ain't used for stubbing because there are - -- no ptrs on B stk. - + VirtualSpAOffset -- Args SpA: trim the A stack to this point at a + -- return; push arguments starting just + -- above this point on a tail call. + + -- This is therefore the A-stk ptr as seen + -- by a case alternative. + + -- 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 top of the + -- continuation's stack! + + VirtualSpBOffset -- Args SpB: Very similar to Args SpA. + -- Two main differences: + -- 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 + -- points to the top word of the return + -- address. + -- + -- 2. It ain't used for stubbing because there are + -- no ptrs on B stk. Sequel - initEobInfo = EndOfBlockInfo 0 0 InRetReg - - \end{code} Any addressing modes inside @Sequel@ must be ``robust,'' in the sense @@ -153,21 +154,21 @@ block. \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 - | UpdateCode CAddrMode -- May be standard update code, or might be - -- the data-type-specific one. + | OnStack VirtualSpBOffset + -- Continuation is on the stack, at the + -- specified location - | 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) + | UpdateCode CAddrMode -- May be standard update code, or might be + -- the data-type-specific one. - SemiTaggingStuff + | 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) + SemiTaggingStuff type SemiTaggingStuff = Maybe -- Maybe[1] we don't have any semi-tagging stuff... @@ -182,17 +183,17 @@ type SemiTaggingStuff type JoinDetails = (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 --- that it's evaluated, and wants to load up the contents and go to the --- join point. +-- The abstract C is executed only from a successful semitagging +-- venture, when a case has looked at a variable, found that it's +-- evaluated, and wants to load up the contents and go to the join +-- point. -- DIRE WARNING. --- 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. +-- 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 :: Sequel -> FCode CAddrMode @@ -576,17 +577,15 @@ nothing. \begin{code} costCentresC :: FAST_STRING -> [CAddrMode] -> Code -costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) - state@(MkCgState absC binds usage) - = if sw_chkr SccProfilingOn +costCentresC macro args _ state@(MkCgState absC binds usage) + = if opt_SccProfilingOn then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage else state profCtrC :: FAST_STRING -> [CAddrMode] -> Code -profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) - state@(MkCgState absC binds usage) - = if not (sw_chkr DoTickyProfiling) +profCtrC macro args _ state@(MkCgState absC binds usage) + = if not opt_DoTickyProfiling then state else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage @@ -616,17 +615,14 @@ getAbsC code info_down (MkCgState absC binds usage) \begin{code} noBlackHolingFlag, costCentresFlag :: FCode Bool -noBlackHolingFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state - = (sw_chkr OmitBlackHoling, state) - -costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state - = (sw_chkr SccProfilingOn, state) +noBlackHolingFlag _ state = (opt_OmitBlackHoling, state) +costCentresFlag _ state = (opt_SccProfilingOn, state) \end{code} \begin{code} moduleName :: FCode FAST_STRING -moduleName (MkCgInfoDown (MkCompInfo _ _ mod_name) _ _) state +moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state = (mod_name, state) \end{code} @@ -802,7 +798,7 @@ dead_slots live_vars fbs das dbs ((v,i):bs) _ -> dead_slots live_vars fbs das dbs bs where size :: Int - size = (getPrimRepSize . primRepFromType . idType) v + size = (getPrimRepSize . typePrimRep . idType) v -- addFreeSlots expects *both* args to be in increasing order addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)] diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 5881fb1..f1a35f6 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -15,8 +15,6 @@ module CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, - mkLiveRegsBitMask, noLiveRegsMask, - dataReturnConvPrim, assignPrimOpResultRegs, @@ -26,27 +24,35 @@ module CgRetConv ( -- and to make the interface self-sufficient... ) where -import AbsCSyn +import Ubiq{-uitous-} +import AbsCLoop -- paranoia checking -import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC, - getPrimOpResultInfo, integerDataCon - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import AbsCSyn -- quite a few things +import AbsCUtils ( mkAbstractCs, getAmodeRep, + amodeCanSurviveGC + ) +import CgCompInfo ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, + mAX_Vanilla_REG, mAX_Float_REG, + mAX_Double_REG + ) +import CmdLineOpts ( opt_ReturnInRegsThreshold ) +import Id ( isDataCon, dataConSig, + DataCon(..), GenId{-instance Eq-} ) -import Type ( getTyConFamilySize, primRepFromType, getTyConDataCons, - TyVarTemplate, TyCon, Class, - TauType(..), ThetaType(..), Type +import Maybes ( catMaybes ) +import PprStyle ( PprStyle(..) ) +import PprType ( TyCon{-instance Outputable-} ) +import PrelInfo ( integerDataCon ) +import PrimOp ( primOpCanTriggerGC, + getPrimOpResultInfo, PrimOpResultInfo(..), + PrimOp{-instance Outputable-} ) -import CgCompInfo -- various things -import CgMonad ( IntSwitchChecker(..) ) -import CmdLineOpts ( GlobalSwitch(..) ) -import Id ( Id, getDataConSig, fIRST_TAG, isDataCon, - DataCon(..), ConTag(..) +import PrimRep ( isFloatingRep, PrimRep(..) ) +import TyCon ( tyConDataCons, tyConFamilySize ) +import Type ( typePrimRep ) +import Util ( zipWithEqual, mapAccumL, isn'tIn, + pprError, pprTrace, panic, assertPanic ) -import Maybes ( catMaybes, Maybe(..) ) -import PrimRep -import Util -import Pretty \end{code} %************************************************************************ @@ -88,11 +94,11 @@ The register assignment given by a @ReturnInRegs@ obeys three rules: ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention ctrlReturnConvAlg tycon - = case (getTyConFamilySize tycon) of - Nothing -> -- pprPanic "ctrlReturnConvAlg:" (ppr PprDebug tycon) - UnvectoredReturn 0 -- e.g., w/ "data Bin" + = case (tyConFamilySize tycon) of + 0 -> pprTrace "ctrlReturnConvAlg:" (ppr PprDebug tycon) $ + UnvectoredReturn 0 -- e.g., w/ "data Bin" - Just size -> -- we're supposed to know... + size -> -- we're supposed to know... if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then VectoredReturn size else @@ -110,68 +116,23 @@ types. If @assign_reg@ runs out of a particular kind of register, then it gives up, returning @ReturnInHeap@. \begin{code} -dataReturnConvAlg :: IntSwitchChecker -> DataCon -> DataReturnConvention +dataReturnConvAlg :: DataCon -> DataReturnConvention -dataReturnConvAlg isw_chkr data_con +dataReturnConvAlg data_con = ASSERT(isDataCon data_con) case leftover_kinds of [] -> ReturnInRegs reg_assignment other -> ReturnInHeap -- Didn't fit in registers where - (_, _, arg_tys, _) = getDataConSig data_con + (_, _, arg_tys, _) = dataConSig data_con (reg_assignment, leftover_kinds) - = assignRegs isw_chkr_to_use - [node, infoptr] -- taken... - (map primRepFromType arg_tys) - - isw_chkr_to_use = isw_chkr + = assignRegs [node, infoptr] -- taken... + (map typePrimRep arg_tys) is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11) \end{code} -\begin{code} -noLiveRegsMask :: Int -- Mask indicating nothing live -noLiveRegsMask = 0 - -mkLiveRegsBitMask - :: [MagicId] -- Candidate live regs; depends what they have in them - -> Int - -mkLiveRegsBitMask regs - = foldl do_reg noLiveRegsMask regs - where - do_reg acc (VanillaReg kind reg_no) - | isFollowableRep kind - = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1))) - - do_reg acc anything_else = acc - - reg_tbl -- ToDo: mk Array! - = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4, - lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8] - -{- --- Completely opaque code. ADR --- What's wrong with: (untested) - -mkLiveRegsBitMask regs - = foldl (+) noLiveRegsMask (map liveness_bit regs) - where - liveness_bit (VanillaReg kind reg_no) - | isFollowableRep kind - = reg_tbl !! (reg_no - 1) - - liveness_bit anything_else - = noLiveRegsBitMask - - reg_tbl - = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4, - lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8] --} -\end{code} - - %************************************************************************ %* * \subsection[CgRetConv-prim]{Return conventions for primitive datatypes} @@ -224,7 +185,7 @@ assignPrimOpResultRegs op ReturnsAlg tycon -> let - cons = getTyConDataCons tycon + cons = tyConDataCons tycon result_regs = concat (map get_return_regs cons) in -- As R1 is dead, it can hold the tag if necessary @@ -233,12 +194,9 @@ assignPrimOpResultRegs op other -> (VanillaReg IntRep ILIT(1)) : result_regs where get_return_regs con - = case (dataReturnConvAlg fake_isw_chkr con) of + = case (dataReturnConvAlg con) of ReturnInRegs regs -> regs ReturnInHeap -> panic "getPrimOpAlgResultRegs" - - fake_isw_chkr :: IntSwitchChecker - fake_isw_chkr x = Nothing \end{code} @assignPrimOpArgsRobust@ is used only for primitive ops which may @@ -269,12 +227,12 @@ makePrimOpArgsRobust op arg_amodes arg_kinds = map getAmodeRep non_robust_amodes (arg_regs, extra_args) - = assignRegs fake_isw_chkr [{-nothing live-}] arg_kinds + = assignRegs [{-nothing live-}] arg_kinds -- Check that all the args fit before returning arg_regs final_arg_regs = case extra_args of [] -> arg_regs - other -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op)) + other -> pprError "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr PprDebug op) arg_assts = mkAbstractCs (zipWithEqual assign_to_reg final_arg_regs non_robust_amodes) @@ -286,12 +244,9 @@ makePrimOpArgsRobust op arg_amodes | otherwise = (tail regs, CReg (head regs)) safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes) - liveness_mask = mkLiveRegsBitMask final_arg_regs + liveness_mask = mkLiveRegsMask final_arg_regs in (safe_amodes, liveness_mask, arg_assts) - where - fake_isw_chkr :: IntSwitchChecker - fake_isw_chkr x = Nothing \end{code} %************************************************************************ @@ -308,15 +263,14 @@ any further registers (even though we might have run out of only one kind of register); we just return immediately with the left-overs specified. \begin{code} -assignRegs :: IntSwitchChecker - -> [MagicId] -- Unavailable registers +assignRegs :: [MagicId] -- Unavailable registers -> [PrimRep] -- Arg or result kinds to assign -> ([MagicId], -- Register assignment in same order -- for *initial segment of* input list [PrimRep])-- leftover kinds -assignRegs isw_chkr regs_in_use kinds - = assign_reg kinds [] (mkRegTbl isw_chkr regs_in_use) +assignRegs regs_in_use kinds + = assign_reg kinds [] (mkRegTbl regs_in_use) where assign_reg :: [PrimRep] -- arg kinds being scrutinized @@ -360,9 +314,9 @@ floatRegNos, doubleRegNos :: [Int] floatRegNos = [1 .. mAX_Float_REG] doubleRegNos = [1 .. mAX_Double_REG] -mkRegTbl :: IntSwitchChecker -> [MagicId] -> ([Int], [Int], [Int]) +mkRegTbl :: [MagicId] -> ([Int], [Int], [Int]) -mkRegTbl isw_chkr regs_in_use +mkRegTbl regs_in_use = (ok_vanilla, ok_float, ok_double) where ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) (taker vanillaRegNos)) @@ -371,7 +325,7 @@ mkRegTbl isw_chkr regs_in_use taker :: [Int] -> [Int] taker rs - = case (isw_chkr ReturnInRegsThreshold) of + = case (opt_ReturnInRegsThreshold) of Nothing -> rs -- no flag set; use all of them Just n -> take n rs diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index 3759aa4..0ad6fc5 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[CgStackery]{Stack management functions} @@ -13,18 +13,19 @@ module CgStackery ( allocAStack, allocBStack, allocUpdateFrame, adjustRealSps, getFinalStackHW, mkVirtStkOffsets, mkStkAmodes - - -- and to make the interface self-sufficient... ) where -import StgSyn +import Ubiq{-uitous-} + import CgMonad import AbsCSyn -import CgUsages ( getSpBRelOffset ) -import Maybes ( Maybe(..) ) -import PrimRep ( getPrimRepSize, retPrimRepSize, separateByPtrFollowness ) -import Util +import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep ) +import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) ) +import PrimRep ( getPrimRepSize, separateByPtrFollowness, + PrimRep(..) + ) +import Util ( mapAccumR, panic ) \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index a22ca46..560adde 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % %******************************************************** %* * @@ -17,37 +17,36 @@ module CgTailCall ( mkPrimReturnCode, tailCallBusiness - - -- and to make the interface self-sufficient... ) where -IMPORT_Trace -import Pretty -- Pretty/Outputable: rm (debugging only) ToDo -import Outputable +import Ubiq{-uitous-} -import StgSyn import CgMonad import AbsCSyn -import Type ( isPrimType, Type ) -import CgBindery ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo ) -import CgCompInfo ( oTHER_TAG, iND_TAG ) -import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg, - mkLiveRegsBitMask, - CtrlReturnConvention(..), DataReturnConvention(..) +import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep ) +import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo ) +import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg, + ctrlReturnConvAlg, CtrlReturnConvention(..), + DataReturnConvention(..) ) import CgStackery ( adjustRealSps, mkStkAmodes ) -import CgUsages ( getSpARelOffset, getSpBRelOffset ) -import CLabel ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel ) -import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) ) -import CmdLineOpts ( GlobalSwitch(..) ) -import Id ( getDataConTyCon, getDataConTag, - idType, getIdPrimRep, fIRST_TAG, Id, - ConTag(..) +import CgUsages ( getSpARelOffset ) +import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel ) +import ClosureInfo ( nodeMustPointToIt, + getEntryConvention, EntryConvention(..) + ) +import CmdLineOpts ( opt_EmitArityChecks, opt_DoSemiTagging ) +import HeapOffs ( zeroOff, VirtualSpAOffset(..) ) +import Id ( idType, dataConTyCon, dataConTag, + fIRST_TAG ) -import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) -import PrimRep ( retPrimRepSize ) -import Util +import Literal ( mkMachInt ) +import Maybes ( assocMaybe ) +import PrimRep ( PrimRep(..) ) +import StgSyn ( StgArg(..), GenStgArg(..), StgLiveVars(..) ) +import Type ( isPrimType ) +import Util ( zipWithEqual, panic, assertPanic ) \end{code} %************************************************************************ @@ -191,8 +190,7 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel -- Set the info pointer, and jump set_info_ptr `thenC` - getIntSwitchChkrC `thenFC` \ isw_chkr -> - absC (CJump (CLbl (update_label isw_chkr) CodePtrRep)) + absC (CJump (CLbl update_label CodePtrRep)) CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so -- we can go right to the alternative @@ -216,14 +214,14 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel ) where - tag = getDataConTag con - tycon = getDataConTyCon con + tag = dataConTag con + tycon = dataConTyCon con return_convention = ctrlReturnConvAlg tycon zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed -- cf AbsCUtils.mkAlgAltsCSwitch - update_label isw_chkr - = case (dataReturnConvAlg isw_chkr con) of + update_label + = case (dataReturnConvAlg con) of ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag @@ -296,7 +294,7 @@ performTailCall fun args live_vars = -- Get all the info we have about the function and args and go on to -- the business end getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) -> - getAtomAmodes args `thenFC` \ arg_amodes -> + getArgAmodes args `thenFC` \ arg_amodes -> tailCallBusiness fun fun_amode lf_info arg_amodes @@ -316,8 +314,9 @@ tailCallBusiness :: Id -> CAddrMode -- Function and its amode -> Code tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts - = isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks -> - + = let + do_arity_chks = opt_EmitArityChecks + in nodeMustPointToIt lf_info `thenFC` \ node_points -> getEntryConvention fun lf_info (map getAmodeRep arg_amodes) `thenFC` \ entry_conv -> @@ -407,7 +406,9 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts adjustRealSps final_spa final_spb `thenC` -- Now decide about semi-tagging - isSwitchSetC DoSemiTagging `thenFC` \ semi_tagging_on -> + let + semi_tagging_on = opt_DoSemiTagging + in case (semi_tagging_on, arg_amodes, node_points, sequel) of -- diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs index 92ceaa4..ff1a554 100644 --- a/ghc/compiler/codeGen/CgUpdate.lhs +++ b/ghc/compiler/codeGen/CgUpdate.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[CgUpdate]{Manipulating update frames} @@ -8,18 +8,15 @@ module CgUpdate ( pushUpdateFrame ) where -import StgSyn +import Ubiq{-uitous-} + import CgMonad import AbsCSyn -import CgCompInfo ( sTD_UF_SIZE, cON_UF_SIZE, - sCC_STD_UF_SIZE, sCC_CON_UF_SIZE, - spARelToInt, spBRelToInt - ) +import CgCompInfo ( sTD_UF_SIZE, sCC_STD_UF_SIZE ) import CgStackery ( allocUpdateFrame ) -import CgUsages -import CmdLineOpts ( GlobalSwitch(..) ) -import Util +import CmdLineOpts ( opt_SccProfilingOn ) +import Util ( assertPanic ) \end{code} @@ -41,8 +38,9 @@ to reflect the frame pushed. pushUpdateFrame :: CAddrMode -> CAddrMode -> Code -> Code pushUpdateFrame updatee vector code - = isSwitchSetC SccProfilingOn `thenFC` \ profiling_on -> - let + = let + profiling_on = opt_SccProfilingOn + -- frame_size *includes* the return address frame_size = if profiling_on then sCC_STD_UF_SIZE diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs index 2e3fec3..eec6be6 100644 --- a/ghc/compiler/codeGen/CgUsages.lhs +++ b/ghc/compiler/codeGen/CgUsages.lhs @@ -15,15 +15,20 @@ module CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset, - freeBStkSlot, - - -- and to make the interface self-sufficient... - AbstractC, HeapOffset, RegRelative, CgState + freeBStkSlot ) where -import AbsCSyn +import Ubiq{-uitous-} +import CgLoop1 -- here for paranoia-checking + +import AbsCSyn ( RegRelative(..), AbstractC, CAddrMode ) import CgMonad -import Util +import HeapOffs ( zeroOff, + VirtualHeapOffset(..), + VirtualSpAOffset(..), + VirtualSpBOffset(..) + ) +import Id ( IdEnv(..) ) \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index dddeddf..ae3bc5c 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,5 +1,5 @@ -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[ClosureInfo]{Data structures which describe closures} @@ -43,35 +43,61 @@ module ClosureInfo ( closureKind, closureTypeDescr, -- profiling - isConstantRep, isSpecRep, isPhantomRep, -- ToDo: Should be in SMRep, perhaps? isStaticClosure, allocProfilingMsg, blackHoleClosureInfo, - getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, - ltSMRepHdr, maybeSelectorInfo, dataConLiveness -- concurrency - - -- and to make the interface self-sufficient... ) where +import Ubiq{-uitous-} +import AbsCLoop -- here for paranoia-checking + import AbsCSyn -import CgMonad -import SMRep import StgSyn +import CgMonad -import Type -import CgCompInfo -- some magic constants -import CgRetConv -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 PrimRep ( PrimRep, getPrimRepSize, separateByPtrFollowness ) -import Util +import CgCompInfo ( mAX_SPEC_SELECTEE_SIZE, + mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject, + mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS, + mAX_SPEC_ALL_NONPTRS, + oTHER_TAG + ) +import CgRetConv ( assignRegs, dataReturnConvAlg, + DataReturnConvention(..) + ) +import CLabel ( mkStdEntryLabel, mkFastEntryLabel, + mkPhantomInfoTableLabel, mkInfoTableLabel, + mkBlackHoleInfoTableLabel, mkVapInfoTableLabel, + mkStaticInfoTableLabel, mkStaticConEntryLabel, + mkConEntryLabel, mkClosureLabel, mkVapEntryLabel + ) +import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent ) +import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize, + intOffsetIntoGoods, + VirtualHeapOffset(..) + ) +import Id ( idType, idPrimRep, getIdArity, + externallyVisibleId, dataConSig, + dataConTag, fIRST_TAG, + isDataCon, dataConArity, dataConTyCon, + isTupleCon, DataCon(..), + GenId{-instance Eq-} + ) +import IdInfo ( arityMaybe ) +import Maybes ( assocMaybe, maybeToBool ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-} ) +import PrimRep ( getPrimRepSize, separateByPtrFollowness ) +import SMRep -- all of it +import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} ) +import Type ( isPrimType, splitForAllTy, splitFunTy, mkFunTys ) +import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic ) + +maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)" +maybeIntLikeTyCon = panic "ClosureInfo.maybeIntLikeTyCon (ToDo)" +getDataSpecTyCon_maybe = panic "ClosureInfo.getDataSpecTyCon_maybe (ToDo)" +getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)" \end{code} The ``wrapper'' data type for closure information: @@ -392,13 +418,13 @@ mkClosureLFInfo False -- don't bother if at top-level -- 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 getIdPrimRep params + (_, params_w_offsets) = layOutDynCon con idPrimRep params maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_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 + is_single_constructor = maybeToBool (maybeTyConSingleCon tycon) + (_,_,_, tycon) = dataConSig con \end{code} Same kind of thing, looking for vector-apply thunks, of the form: @@ -452,7 +478,7 @@ mkConLFInfo :: DataCon -> LambdaFormInfo mkConLFInfo con = ASSERT(isDataCon con) let - arity = getDataConArity con + arity = dataConArity con in if isTupleCon con then LFTuple con (arity == 0) @@ -691,7 +717,7 @@ chooseDynSMRep lf_info tot_wds ptr_wds else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep else SpecRep where - tycon = getDataConTyCon con + tycon = dataConTyCon con _ -> SpecRep in @@ -712,14 +738,15 @@ smaller offsets than the unboxed things, and furthermore, the offsets in the result list \begin{code} -mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager +mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager -> (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 - Int, -- Number of words allocated for *pointers* - [(a, VirtualHeapOffset)]) -- Things with their offsets from start of object - -- in order of increasing offset + -- w/ a kind, we can find boxedness + -> [a] -- Things to make offsets for + -> (Int, -- *Total* number of words allocated + Int, -- Number of words allocated for *pointers* + [(a, VirtualHeapOffset)]) + -- Things with their offsets from start of object + -- in order of increasing offset -- First in list gets lowest offset, which is initial offset + 1. @@ -748,8 +775,9 @@ Be sure to see the stg-details notes about these... \begin{code} nodeMustPointToIt :: LambdaFormInfo -> FCode Bool nodeMustPointToIt lf_info - = isSwitchSetC SccProfilingOn `thenFC` \ do_profiling -> - + = let + do_profiling = opt_SccProfilingOn + in case lf_info of LFReEntrant top arity no_fvs -> returnFC ( not no_fvs || -- Certainly if it has fvs we need to point to it @@ -843,8 +871,9 @@ getEntryConvention :: Id -- Function being applied getEntryConvention id lf_info arg_kinds = nodeMustPointToIt lf_info `thenFC` \ node_points -> - isSwitchSetC ForConcurrent `thenFC` \ is_concurrent -> - getIntSwitchChkrC `thenFC` \ isw_chkr -> + let + is_concurrent = opt_ForConcurrent + in returnFC ( if (node_points && is_concurrent) then ViaNode else @@ -857,7 +886,7 @@ getEntryConvention id lf_info arg_kinds else DirectEntry (mkFastEntryLabel id arity) arity arg_regs where - (arg_regs, _) = assignRegs isw_chkr live_regs (take arity arg_kinds) + (arg_regs, _) = assignRegs live_regs (take arity arg_kinds) live_regs = if node_points then [node] else [] LFCon con zero_arity @@ -887,7 +916,7 @@ getEntryConvention id lf_info arg_kinds -> ASSERT(arity == length arg_kinds) DirectEntry (mkStdEntryLabel id) arity arg_regs where - (arg_regs, _) = assignRegs isw_chkr live_regs arg_kinds + (arg_regs, _) = assignRegs live_regs arg_kinds live_regs = if node_points then [node] else [] ) @@ -1067,21 +1096,6 @@ noUpdVapRequired binder_info %************************************************************************ \begin{code} -isConstantRep, isSpecRep, isStaticRep, isPhantomRep, isIntLikeRep :: SMRep -> Bool -isConstantRep (SpecialisedRep ConstantRep _ _ _) = True -isConstantRep other = False - -isSpecRep (SpecialisedRep kind _ _ _) = True -- All the kinds of Spec closures -isSpecRep other = False -- True indicates that the _VHS is 0 ! - -isStaticRep (StaticRep _ _) = True -isStaticRep _ = False - -isPhantomRep PhantomRep = True -isPhantomRep _ = False - -isIntLikeRep (SpecialisedRep IntLikeRep _ _ _) = True -isIntLikeRep other = False isStaticClosure :: ClosureInfo -> Bool isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep @@ -1121,11 +1135,9 @@ closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id]) -- rather than take it from the Id. The Id is probably just "f"! closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _) - = getUniDataSpecTyCon_maybe (funResultTy de_foralld_ty (length args)) - where - (_, de_foralld_ty) = splitForalls (idType fun_id) + = getDataSpecTyCon_maybe (fun_result_ty (length args) fun_id) -closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (idType id) +closureType (MkClosureInfo id lf _) = getDataSpecTyCon_maybe (idType id) \end{code} @closureReturnsUnboxedType@ is used to check whether a closure, {\em @@ -1140,13 +1152,20 @@ overflow checks. closureReturnsUnboxedType :: ClosureInfo -> Bool closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _) - = isPrimType (funResultTy de_foralld_ty arity) - where - (_, de_foralld_ty) = splitForalls (idType fun_id) + = isPrimType (fun_result_ty arity fun_id) closureReturnsUnboxedType other_closure = False -- All non-function closures aren't functions, -- and hence are boxed, since they are heap alloc'd + +-- ToDo: need anything like this in Type.lhs? +fun_result_ty arity id + = let + (_, de_foralld_ty) = splitForAllTy (idType id) + (arg_tys, res_ty) = splitFunTy{-w/ dicts as args?-} de_foralld_ty + in + ASSERT(arity >= 0 && length arg_tys >= arity) + mkFunTys (drop arity arg_tys) res_ty \end{code} \begin{code} @@ -1154,7 +1173,7 @@ closureSemiTag :: ClosureInfo -> Int closureSemiTag (MkClosureInfo _ lf_info _) = case lf_info of - LFCon data_con _ -> getDataConTag data_con - fIRST_TAG + LFCon data_con _ -> dataConTag data_con - fIRST_TAG LFTuple _ _ -> 0 _ -> fromInteger oTHER_TAG \end{code} @@ -1248,26 +1267,26 @@ allocProfilingMsg (MkClosureInfo _ lf_info _) LFImported -> panic "ALLOC_IMP" \end{code} -We need a black-hole closure info to pass to @allocDynClosure@ -when we want to allocate the black hole on entry to a CAF. +We need a black-hole closure info to pass to @allocDynClosure@ when we +want to allocate the black hole on entry to a CAF. \begin{code} -blackHoleClosureInfo (MkClosureInfo id _ _) = MkClosureInfo id LFBlackHole BlackHoleRep +blackHoleClosureInfo (MkClosureInfo id _ _) + = MkClosureInfo id LFBlackHole BlackHoleRep \end{code} -The register liveness when returning from a constructor. For simplicity, -we claim just [node] is live for all but PhantomRep's. In truth, this means -that non-constructor info tables also claim node, but since their liveness -information is never used, we don't care. +The register liveness when returning from a constructor. For +simplicity, we claim just [node] is live for all but PhantomRep's. In +truth, this means that non-constructor info tables also claim node, +but since their liveness information is never used, we don't care. \begin{code} - -dataConLiveness isw_chkr (MkClosureInfo con _ PhantomRep) - = case (dataReturnConvAlg isw_chkr con) of - ReturnInRegs regs -> mkLiveRegsBitMask regs +dataConLiveness (MkClosureInfo con _ PhantomRep) + = case (dataReturnConvAlg con) of + ReturnInRegs regs -> mkLiveRegsMask regs ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???" -dataConLiveness _ _ = mkLiveRegsBitMask [node] +dataConLiveness _ = mkLiveRegsMask [node] \end{code} %************************************************************************ @@ -1303,8 +1322,7 @@ closureKind (MkClosureInfo _ lf _) closureTypeDescr :: ClosureInfo -> String closureTypeDescr (MkClosureInfo id lf _) = if (isDataCon id) then -- DataCon has function types - _UNPK_ (getOccurrenceName (getDataConTyCon id)) -- We want the TyCon not the -> + _UNPK_ (getOccurrenceName (dataConTyCon id)) -- We want the TyCon not the -> else - getUniTyDescription (idType id) + getTyDescription (idType id) \end{code} - diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index d8112a8..2b193da 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[CodeGen]{@CodeGen@: main module of the code generator} @@ -19,28 +19,32 @@ functions drive the mangling of top-level bindings. module CodeGen ( codeGen ) where +import Ubiq{-uitous-} + import StgSyn import CgMonad import AbsCSyn -import CLabel ( modnameToC ) +import AbsCUtils ( mkAbstractCs, mkAbsCStmts ) +import Bag ( foldBag ) import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon ) -import CgConTbls ( genStaticConBits, TCE(..), UniqFM ) -import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo ) -import CmdLineOpts -import FiniteMap ( FiniteMap ) -import Maybes ( Maybe(..) ) -import Pretty -- debugging only -import PrimRep ( getPrimRepSize ) -import Util +import CgConTbls ( genStaticConBits ) +import ClosureInfo ( mkClosureLFInfo ) +import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude, + opt_EnsureSplittableC, opt_SccGroup + ) +import CStrings ( modnameToC ) +import Maybes ( maybeToBool ) +import PrimRep ( getPrimRepSize, PrimRep(..) ) +import Util ( panic, assertPanic ) \end{code} \begin{code} codeGen :: FAST_STRING -- module name -> ([CostCentre], -- local cost-centres needing declaring/registering [CostCentre]) -- "extern" cost-centres needing declaring - -> [FAST_STRING] -- import names + -> Bag FAST_STRING -- import names -> [TyCon] -- tycons with data constructors to convert -> FiniteMap TyCon [(Bool, [Maybe Type])] -- tycon specialisation info @@ -51,11 +55,11 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg = let doing_profiling = opt_SccProfilingOn compiling_prelude = opt_CompilingPrelude - maybe_split = if (switch_is_on (EnsureSplittableC (panic "codeGen:esc"))) + maybe_split = if maybeToBool (opt_EnsureSplittableC) then CSplitMarker else AbsCNop - cinfo = MkCompInfo switch_is_on int_switch_set mod_name + cinfo = MkCompInfo mod_name in if not doing_profiling then mkAbstractCs [ @@ -85,15 +89,16 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg initC cinfo (cgTopBindings maybe_split stg_pgm) ] where ----------------- - grp_name = case (stringSwitchSet sw_lookup_fn SccGroup) of - Just xx -> _PK_ xx + grp_name = case opt_SccGroup of + Just xx -> xx Nothing -> mod_name -- default: module name ----------------- mkCcRegister ccs import_names = let register_ccs = mkAbstractCs (map mk_register ccs) - register_imports = mkAbstractCs (map mk_import_register import_names) + register_imports + = foldBag mkAbsCStmts mk_import_register AbsCNop import_names in mkAbstractCs [ CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep], diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs index 4adcfd7..99432c7 100644 --- a/ghc/compiler/codeGen/SMRep.lhs +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -12,7 +12,9 @@ Other modules should access this info through ClosureInfo. module SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..), getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, - ltSMRepHdr + ltSMRepHdr, + isConstantRep, isSpecRep, isStaticRep, isPhantomRep, + isIntLikeRep ) where import Ubiq{-uitous-} @@ -129,7 +131,27 @@ MuTupleRep == MUTUPLE --jim -} +\end{code} + +\begin{code} +isConstantRep, isSpecRep, isStaticRep, isPhantomRep, isIntLikeRep :: SMRep -> Bool +isConstantRep (SpecialisedRep ConstantRep _ _ _) = True +isConstantRep other = False + +isSpecRep (SpecialisedRep kind _ _ _) = True -- All the kinds of Spec closures +isSpecRep other = False -- True indicates that the _VHS is 0 ! + +isStaticRep (StaticRep _ _) = True +isStaticRep _ = False +isPhantomRep PhantomRep = True +isPhantomRep _ = False + +isIntLikeRep (SpecialisedRep IntLikeRep _ _ _) = True +isIntLikeRep other = False +\end{code} + +\begin{code} instance Eq SMRep where (SpecialisedRep k1 a1 b1 _) == (SpecialisedRep k2 a2 b2 _) = (tagOf_SMSpecRepKind k1) _EQ_ (tagOf_SMSpecRepKind k2) && a1 == a2 && b1 == b2 diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index 90f7656..ecae173 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -26,7 +26,7 @@ import Id ( idType, mkSysLocal, GenId{-instances-} ) import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon ) -import TyCon ( TyCon{-instance-} ) +import TyCon ( isBoxedTyCon, TyCon{-instance-} ) import Type ( maybeAppDataTyCon, eqTy ) import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) import Util ( zipEqual, zipWithEqual, assertPanic, panic ) @@ -34,7 +34,6 @@ import Util ( zipEqual, zipWithEqual, assertPanic, panic ) infixr 9 `thenL` updateIdType = panic "CoreLift.updateIdType" -isBoxedTyCon = panic "CoreLift.isBoxedTyCon" \end{code} %************************************************************************ diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index a08c45f..e31af01 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -21,6 +21,7 @@ import Literal ( literalType, Literal{-instance-} ) import Id ( idType, isBottomingId, getInstantiatedDataConSig, GenId{-instances-} ) +import Maybes ( catMaybes ) import Outputable ( Outputable(..) ) import PprCore import PprStyle ( PprStyle(..) ) @@ -32,11 +33,13 @@ import SrcLoc ( SrcLoc ) import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe, isPrimType,getTypeKind,instantiateTy, mkForAllUsageTy,getForAllUsageTy,instantiateUsage, - maybeAppDataTyCon, eqTy ) -import TyCon ( isPrimTyCon,isVisibleDataTyCon ) + maybeAppDataTyCon, eqTy + ) +import TyCon ( isPrimTyCon, tyConFamilySize ) import TyVar ( getTyVarKind, GenTyVar{-instances-} ) import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets, - unionUniqSets, elementOfUniqSet, UniqSet(..) ) + unionUniqSets, elementOfUniqSet, UniqSet(..) + ) import Unique ( Unique ) import Usage ( GenUsage ) import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic ) @@ -89,9 +92,7 @@ lintCoreBindings sty whoDunnit spec_done binds ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"), msg sty, ppStr "*** Offending Program ***", - ppAboves - (map (pprCoreBinding sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (ppr sty)) - binds), + ppAboves (map (pprCoreBinding sty) binds), ppStr "*** End of Offense ***" ]) where @@ -297,23 +298,28 @@ lintCoreAlts :: CoreCaseAlts -> TyCon -- TyCon pinned on the case -> 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 +lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon = -- 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) + -- Check we are scrutinising a proper datatype + -- (ToDo: robustify) + addErrIfL (not (tyConFamilySize tycon >= 1)) (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) + -- Check the result types + case catMaybes (maybe_deflt_ty : maybe_alt_tys) of + [] -> returnL Nothing -lintCoreAlts (PrimAlts alts deflt) ty tycon + (first_ty:tys) -> mapL check tys `seqL` + returnL (Just first_ty) + where + check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts) + +lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon = -- Check tycon is a primitive tycon addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon) `seqL` @@ -321,21 +327,16 @@ lintCoreAlts (PrimAlts alts deflt) ty tycon `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 + case catMaybes (maybe_deflt_ty : maybe_alt_tys) of [] -> returnL Nothing (first_ty:tys) -> mapL check tys `seqL` returnL (Just first_ty) where - check ty = checkTys first_ty ty (mkCaseAltMsg alts) --} + check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts) -lintAlgAlt scrut_ty (con,args,rhs) +lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs) = (case maybeAppDataTyCon scrut_ty of Nothing -> addErrL (mkAlgAltMsg1 scrut_ty) @@ -551,7 +552,7 @@ mkCasePrimMsg tycon sty mkCaseAbstractMsg :: TyCon -> ErrMsg mkCaseAbstractMsg tycon sty - = ppAbove (ppStr "An algebraic case on an abstract type:") + = ppAbove (ppStr "An algebraic case on some weird type:") (ppr sty tycon) mkDefltMsg :: CoreCaseDefault -> ErrMsg diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 037afb4..2e017b8 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -17,7 +17,7 @@ module CoreSyn ( mkApp, mkCon, mkPrim, mkValLam, mkTyLam, mkUseLam, mkLam, - collectBinders, + collectBinders, isValBinder, notValBinder, collectArgs, isValArg, notValArg, numValArgs, @@ -57,13 +57,10 @@ module CoreSyn ( import Ubiq{-uitous-} import CostCentre ( showCostCentre, CostCentre ) -import Id ( idType ) +import Id ( idType, GenId{-instance Eq-} ) +import Type ( isUnboxedType ) import Usage ( UVar(..) ) import Util ( panic, assertPanic ) - -isUnboxedDataType = panic "CoreSyn.isUnboxedDataType" ---eqId :: Id -> Id -> Bool -eqId = panic "CoreSyn.eqId" \end{code} %************************************************************************ @@ -197,12 +194,13 @@ being bound has unboxed type. We have different variants ... (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 +mkCoLetAny :: GenCoreBinding Id Id tyvar uvar + -> GenCoreExpr Id Id tyvar uvar + -> GenCoreExpr Id Id tyvar uvar +mkCoLetsAny :: [GenCoreBinding Id Id tyvar uvar] -> + GenCoreExpr Id Id tyvar uvar -> + GenCoreExpr Id Id 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 @@ -216,7 +214,7 @@ 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 + Var binder2 | binder == binder2 -> rhs -- hey, I have the rhs other -> Let bind body @@ -231,9 +229,9 @@ mkCoLetAny bind@(NonRec binder rhs) body mkCoLetNoUnboxed bind@(Rec binds) body = mkCoLetrecNoUnboxed binds body mkCoLetNoUnboxed bind@(NonRec binder rhs) body - = --ASSERT (not (isUnboxedDataType (idType binder))) + = --ASSERT (not (isUnboxedType (idType binder))) case body of - Var binder2 | binder `eqId` binder2 + Var binder2 | binder == binder2 -> rhs -- hey, I have the rhs other -> Let bind body @@ -251,7 +249,7 @@ mkCoLetrecNoUnboxed binds body Let (Rec binds) body where is_boxed_bind (binder, rhs) - = (not . isUnboxedDataType . idType) binder + = (not . isUnboxedType . idType) binder \end{code} \begin{code} @@ -264,10 +262,10 @@ mkCoLetUnboxedToCase bind@(Rec binds) body = mkCoLetrecNoUnboxed binds body mkCoLetUnboxedToCase bind@(NonRec binder rhs) body = case body of - Var binder2 | binder `eqId` binder2 + Var binder2 | binder == binder2 -> rhs -- hey, I have the rhs other - -> if (not (isUnboxedDataType (idType binder))) then + -> if (not (isUnboxedType (idType binder))) then Let bind body -- boxed... else Case rhs -- unboxed... @@ -341,6 +339,11 @@ data GenCoreBinder val_bdr tyvar uvar = ValBinder val_bdr | TyBinder tyvar | UsageBinder uvar + +isValBinder (ValBinder _) = True +isValBinder _ = False + +notValBinder = not . isValBinder \end{code} Clump Lams together if possible. @@ -379,42 +382,25 @@ collectBinders :: GenCoreExpr val_bdr val_occ tyvar uvar -> ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar) -collectBinders (Lam (UsageBinder u) body) - = let - (uvars, tyvars, args, final_body) = collectBinders body - in - (u:uvars, tyvars, args, final_body) - -collectBinders other - = let - (tyvars, args, body) = dig_for_tyvars other - in - ([], tyvars, args, body) +collectBinders expr + = usages expr [] 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) + usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc) + usages other uacc + = case (tyvars other []) of { (tacc, vacc, expr) -> + (reverse uacc, tacc, vacc, expr) } + + tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc) + tyvars other tacc + = ASSERT(not (usage_lambda other)) + case (valvars other []) of { (vacc, expr) -> + (reverse tacc, vacc, expr) } + + valvars (Lam (ValBinder v) body) vacc = valvars body (v:vacc) + valvars other vacc + = ASSERT(not (usage_lambda other)) + ASSERT(not (tyvar_lambda other)) + (reverse vacc, other) --------------------------------------- usage_lambda (Lam (UsageBinder _) _) = True @@ -489,13 +475,36 @@ and the arguments to which it is applied. \begin{code} collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar -> (GenCoreExpr val_bdr val_occ tyvar uvar, - [GenCoreArg val_occ tyvar uvar]) + [GenUsage uvar], + [GenType tyvar uvar], + [GenCoreArg val_occ tyvar uvar]{-ValArgs-}) collectArgs expr - = collect expr [] + = usages expr [] where - collect (App fun arg) args = collect fun (arg : args) - collect fun args = (fun, args) + usages (App fun (UsageArg u)) uacc = usages fun (u:uacc) + usages fun uacc + = case (tyvars fun []) of { (expr, tacc, vacc) -> + (expr, uacc, tacc, vacc) } + + tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc) + tyvars fun tacc + = ASSERT(not (usage_app fun)) + case (valvars fun []) of { (expr, vacc) -> + (expr, tacc, vacc) } + + valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc) + valvars fun vacc + = ASSERT(not (usage_app fun)) + ASSERT(not (ty_app fun)) + (fun, vacc) + + --------------------------------------- + usage_app (App _ (UsageArg _)) = True + usage_app _ = False + + ty_app (App _ (TyArg _)) = True + ty_app _ = False \end{code} %************************************************************************ diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 7aec06e..9266898 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -28,7 +28,8 @@ module CoreUnfold ( ) where import Ubiq -import IdLoop -- for paranoia checking +import IdLoop -- for paranoia checking; + -- and also to get mkMagicUnfoldingFun import PrelLoop -- for paranoia checking import Bag ( emptyBag, unitBag, unionBags, Bag ) @@ -38,24 +39,21 @@ import CgCompInfo ( uNFOLDING_CHEAP_OP_COST, uNFOLDING_NOREP_LIT_COST ) import CoreSyn -import CoreUtils ( coreExprType ) +import CoreUtils ( coreExprType, manifestlyWHNF ) import CostCentre ( ccMentionsId ) import Id ( IdSet(..), GenId{-instances-} ) import IdInfo ( bottomIsGuaranteed ) import Literal ( isNoRepLit, isLitLitLit ) -import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun ) import Pretty -import PrimOp ( PrimOp(..) ) +import PrimOp ( primOpCanTriggerGC, PrimOp(..) ) +import TyCon ( tyConFamilySize ) import Type ( getAppDataTyCon ) -import UniqSet ( emptyUniqSet, singletonUniqSet, mkUniqSet, - unionUniqSets +import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, + addOneToUniqSet, 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} @@ -333,8 +331,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr ------------ 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 }) + `addSizeN` (tyConFamilySize tycon) -- NB: we charge N for an alg. "case", where N is -- the number of constructors in the thing being eval'd. -- (You'll eventually get a "discount" of N if you @@ -426,7 +423,7 @@ add1 :: IdSet -> Id -> IdSet add_some :: IdSet -> [Id] -> IdSet no_in_scopes = emptyUniqSet -in_scopes `add1` x = in_scopes `unionUniqSets` singletonUniqSet x +in_scopes `add1` x = addOneToUniqSet in_scopes x in_scopes `add_some` xs = in_scopes `unionUniqSets` mkUniqSet xs \end{code} @@ -747,7 +744,7 @@ ppr_uf_Expr in_scopes (SCC cc body) \begin{code} ppr_uf_Binder :: Id -> Pretty ppr_uf_Binder v - = ppBesides [ppLparen, pprIdInUnfolding (singletonUniqSet v) v, ppPStr SLIT(" :: "), + = ppBesides [ppLparen, pprIdInUnfolding (unitUniqSet v) v, ppPStr SLIT(" :: "), ppr ppr_Unfolding (idType v), ppRparen] ppr_uf_Atom in_scopes (LitArg l) = ppr ppr_Unfolding l diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 363cecb..ddc7658 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -9,19 +9,19 @@ module CoreUtils ( coreExprType, coreAltsType, - substCoreExpr + substCoreExpr, substCoreBindings , mkCoreIfThenElse , mkErrorApp, escErrorMsg , argToExpr , unTagBinders, unTagBindersAlts , manifestlyWHNF, manifestlyBottom + , maybeErrorApp + , nonErrorRHSs + , squashableDictishCcExpr {- exprSmallEnoughToDup, coreExprArity, isWrapperFor, - maybeErrorApp, - nonErrorRHSs, - squashableDictishCcExpr, -} ) where @@ -38,10 +38,10 @@ import Id ( idType, mkSysLocal, getIdArity, isBottomingId, ) import IdInfo ( arityMaybe ) import Literal ( literalType, isNoRepLit, Literal(..) ) -import Maybes ( catMaybes ) +import Maybes ( catMaybes, maybeToBool ) import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} ) import PprStyle ( PprStyle(..) ) -import PprType ( GenType{-instances-}, GenTyVar{-instance-} ) +import PprType ( GenType{-instances-} ) import Pretty ( ppAboves ) import PrelInfo ( trueDataCon, falseDataCon, augmentId, buildId, @@ -49,21 +49,21 @@ import PrelInfo ( trueDataCon, falseDataCon, ) import PrimOp ( primOpType, PrimOp(..) ) import SrcLoc ( mkUnknownSrcLoc ) -import TyVar ( isNullTyVarEnv, TyVarEnv(..), GenTyVar{-instances-} ) -import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, - getFunTy_maybe, applyTy, splitSigmaTy +import TyVar ( isNullTyVarEnv, TyVarEnv(..) ) +import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, + getFunTy_maybe, applyTy, isPrimType, + splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy ) -import Unique ( Unique{-instances-} ) import UniqSupply ( initUs, returnUs, thenUs, mapUs, mapAndUnzipUs, UniqSM(..), UniqSupply ) +import Usage ( UVar(..) ) 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} %************************************************************************ @@ -253,11 +253,11 @@ exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op) -- Could check # of exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit) exprSmallEnoughToDup expr -- for now, just: applied to - = case (collectArgs expr) of { (fun, args) -> + = case (collectArgs expr) of { (fun, _, _, vargs) -> case fun of Var v -> v /= buildId && v /= augmentId - && length args <= 6 -- or 10 or 1 or 4 or anything smallish. + && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish. _ -> False } -} @@ -280,14 +280,13 @@ manifestlyWHNF (SCC _ e) = manifestlyWHNF e manifestlyWHNF (Let _ e) = False manifestlyWHNF (Case _ _) = False -manifestlyWHNF (Lam (ValBinder _) _) = True -manifestlyWHNF (Lam other_binder e) = manifestlyWHNF e +manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e manifestlyWHNF other_expr -- look for manifest partial application - = case (collectArgs other_expr) of { (fun, args) -> + = case (collectArgs other_expr) of { (fun, _, _, vargs) -> case fun of Var f -> let - num_val_args = numValArgs args + num_val_args = length vargs in num_val_args == 0 -- Just a type application of -- a variable (f t1 t2 t3); @@ -317,8 +316,7 @@ manifestlyBottom (SCC _ e) = manifestlyBottom e manifestlyBottom (Let _ e) = manifestlyBottom e -- We do not assume \x.bottom == bottom: -manifestlyBottom (Lam (ValBinder _) _) = False -manifestlyBottom (Lam other_binder e) = manifestlyBottom e +manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e manifestlyBottom (Case e a) = manifestlyBottom e @@ -335,7 +333,7 @@ manifestlyBottom (Case e a) mbdef (BindDefault _ e') = manifestlyBottom e' manifestlyBottom other_expr -- look for manifest partial application - = case (collectArgs other_expr) of { (fun, args) -> + = case (collectArgs other_expr) of { (fun, _, _, _) -> case fun of Var f | isBottomingId f -> True -- Application of a function which always gives @@ -389,11 +387,11 @@ expr `isWrapperFor` var -------------- unravel_casing case_ables (Case scrut alts) - = case (collectArgs scrut) of { (fun, args) -> + = case (collectArgs scrut) of { (fun, _, _, vargs) -> case fun of Var scrut_var -> let answer = - scrut_var /= var && all (doesn't_mention var) args + scrut_var /= var && all (doesn't_mention var) vargs && scrut_var `is_elem` case_ables && unravel_alts case_ables alts in @@ -403,15 +401,15 @@ expr `isWrapperFor` var } unravel_casing case_ables other_expr - = case (collectArgs other_expr) of { (fun, args) -> + = case (collectArgs other_expr) of { (fun, _, _, vargs) -> 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 + && all (doesn't_mention var) vargs + && all (only_from case_ables) vargs in answer @@ -508,23 +506,24 @@ Example: Notice that the \tr{} don't get duplicated. \begin{code} -{- LATER: -nonErrorRHSs :: GenCoreCaseAlts binder Id -> [GenCoreExpr binder Id] +nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar] -nonErrorRHSs alts = filter not_error_app (find_rhss alts) +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 + find_rhss (AlgAlts as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt + find_rhss (PrimAlts as deflt) = [rhs | (_,rhs) <- as] ++ deflt_rhs deflt deflt_rhs NoDefault = [] deflt_rhs (BindDefault _ rhs) = [rhs] - not_error_app rhs = case maybeErrorApp rhs Nothing of - Just _ -> False - Nothing -> True + not_error_app rhs + = case (maybeErrorApp rhs Nothing) of + Just _ -> False + Nothing -> True \end{code} -maybeErrorApp checkes whether an expression is of the form +maybeErrorApp checks whether an expression is of the form error ty args @@ -540,24 +539,24 @@ Here's where it is useful: ===> 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@. +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). +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? +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 +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: +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 @@ -566,47 +565,47 @@ to 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 + :: GenCoreExpr a Id TyVar UVar -- 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 a Id TyVar UVar) maybeErrorApp expr result_ty_maybe - = case collectArgs expr of - (Var fun, (TypeArg ty : other_args)) + = case (collectArgs expr) of + (Var fun, [{-no usage???-}], [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) -> + + case (splitSigmaTy (idType fun)) of + ([tyvar], [], tau_ty) -> + case (splitFunTy 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 + if (res_ty `eqTy` mkTyVarTy tyvar) + && n_args_to_keep <= length other_args then -- Phew! We're in business - Just (mkGenApp (Var fun) - (TypeArg result_ty : args_to_keep)) + Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep)) else Nothing } - other -> -- Function type wrong shape - Nothing + other -> Nothing -- Function type wrong shape other -> Nothing where Just result_ty = result_ty_maybe \end{code} \begin{code} -squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b -> Bool +squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool squashableDictishCcExpr cc expr = if not (isDictCC cc) then @@ -615,11 +614,11 @@ squashableDictishCcExpr cc expr 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 --} + squashable (Con _ _) = True -- I think so... WDP 94/09 + squashable (Prim _ _) = True -- ditto + squashable (App f a) + | notValArg a = squashable f + squashable other = False \end{code} %************************************************************************ @@ -629,14 +628,25 @@ squashableDictishCcExpr cc expr %************************************************************************ \begin{code} +substCoreBindings :: ValEnv + -> TypeEnv -- TyVar=>Type + -> [CoreBinding] + -> UniqSM [CoreBinding] + substCoreExpr :: ValEnv -> TypeEnv -- TyVar=>Type -> CoreExpr -> UniqSM CoreExpr -substCoreExpr venv tenv expr +substCoreBindings venv tenv binds -- if the envs are empty, then avoid doing anything = if (isNullIdEnv venv && isNullTyVarEnv tenv) then + returnUs binds + else + do_CoreBindings venv tenv binds + +substCoreExpr venv tenv expr + = if (isNullIdEnv venv && isNullTyVarEnv tenv) then returnUs expr else do_CoreExpr venv tenv expr diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index 8879ffe..8703b34 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -26,14 +26,14 @@ import AnnCoreSyn -- output import CoreSyn import Id ( idType, getIdArity, isBottomingId, - emptyIdSet, singletonIdSet, mkIdSet, + emptyIdSet, unitIdSet, mkIdSet, elementOfIdSet, minusIdSet, unionManyIdSets, IdSet(..) ) import IdInfo ( arityMaybe ) import PrimOp ( PrimOp(..) ) import Type ( tyVarsOfType ) -import TyVar ( emptyTyVarSet, singletonTyVarSet, minusTyVarSet, +import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet, intersectTyVarSets, TyVarSet(..) ) @@ -74,8 +74,8 @@ data FVInfo noFreeIds = emptyIdSet noFreeTyVars = emptyTyVarSet noFreeAnything = (noFreeIds, noFreeTyVars) -aFreeId i = singletonIdSet i -aFreeTyVar t = singletonTyVarSet t +aFreeId i = unitIdSet i +aFreeTyVar t = unitTyVarSet t is_among = elementOfIdSet munge_id_ty i = tyVarsOfType (idType i) combine = unionUniqSets -- used both for {Id,TyVar}Sets @@ -171,13 +171,13 @@ fvExpr id_cands tyvar_cands (Lam (UsageBinder uvar) body) = panic "fvExpr:Lam UsageBinder" fvExpr id_cands tyvar_cands (Lam b@(ValBinder binder) body) - = (FVInfo (freeVarsOf body2 `minusIdSet` singletonIdSet binder) + = (FVInfo (freeVarsOf body2 `minusIdSet` unitIdSet binder) (freeTyVarsOf body2 `combine` munge_id_ty binder) leakiness, AnnLam b body2) where -- We need to collect free tyvars from the binders - body2 = fvExpr (singletonIdSet binder `combine` id_cands) tyvar_cands body + body2 = fvExpr (unitIdSet binder `combine` id_cands) tyvar_cands body leakiness = case leakinessOf body2 of MightLeak -> LeakFree 1 @@ -412,7 +412,7 @@ addExprFVs fv_cand in_scope (Lam binder body) TyBinder t -> (TyBinder t, emptyIdSet) UsageBinder u -> (UsageBinder u, emptyIdSet) ValBinder b -> (ValBinder (b, lam_fvs), - singletonIdSet b) + unitIdSet b) new_in_scope = in_scope `combine` binder_set (new_body, body_fvs) = addExprFVs fv_cand new_in_scope body diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 770e9bf..4a503e4 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -14,8 +14,7 @@ module PprCore ( pprCoreExpr, pprCoreBinding, pprBigCoreBinder, - pprTypedCoreBinder, - pprPlainCoreBinding + pprTypedCoreBinder -- these are here to make the instances go in 0.26: #if __GLASGOW_HASKELL__ <= 26 @@ -34,9 +33,8 @@ import Id ( idType, getIdInfo, getIdStrictness, import IdInfo ( ppIdInfo, StrictnessInfo(..) ) import Literal ( Literal{-instances-} ) import Outputable -- quite a few things -import PprType ( pprType_Internal, - GenType{-instances-}, GenTyVar{-instance-} - ) +import PprEnv +import PprType ( GenType{-instances-}, GenTyVar{-instance-} ) import PprStyle ( PprStyle(..) ) import Pretty import PrimOp ( PrimOp{-instances-} ) @@ -58,7 +56,7 @@ function for ``major'' val_bdrs (those next to equal signs :-), 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 +@PprEnv@...) @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. @@ -66,9 +64,9 @@ print something. @pprParendCoreExpr@ puts parens around non-atomic Core expressions. \begin{code} -pprPlainCoreBinding :: PprStyle -> CoreBinding -> Pretty +pprCoreBinding :: PprStyle -> CoreBinding -> Pretty -pprCoreBinding +pprGenCoreBinding :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable bndr, @@ -80,14 +78,27 @@ pprCoreBinding -> 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) +pprGenCoreBinding sty pbdr1 pbdr2 pocc bind + = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind + +init_ppr_env sty pbdr1 pbdr2 pocc + = initPprEnv sty + (Just (ppr sty)) -- literals + (Just (ppr sty)) -- data cons + (Just (ppr sty)) -- primops + (Just (\ cc -> ppStr (showCostCentre sty True cc))) + (Just (ppr sty)) -- tyvars + (Just (ppr sty)) -- usage vars + (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars + (Just (ppr sty)) -- types + (Just (ppr sty)) -- usages + +-------------- +pprCoreBinding sty (NonRec binder expr) = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) -pprPlainCoreBinding sty (Rec binds) +pprCoreBinding sty (Rec binds) = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"), ppAboves (map ppr_bind binds), ifPprDebug sty (ppStr "{- end plain Rec -}")] @@ -98,7 +109,16 @@ pprPlainCoreBinding sty (Rec binds) \end{code} \begin{code} -pprCoreExpr, pprParendCoreExpr +pprCoreExpr + :: PprStyle + -> (Id -> Pretty) -- to print "major" val_bdrs + -> (Id -> Pretty) -- to print "minor" val_bdrs + -> (Id -> Pretty) -- to print bindees + -> CoreExpr + -> Pretty +pprCoreExpr = pprGenCoreExpr + +pprGenCoreExpr, pprParendCoreExpr :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable bndr, Outputable occ) @@ -109,8 +129,8 @@ pprCoreExpr, pprParendCoreExpr -> GenCoreExpr bndr occ tyvar uvar -> Pretty -pprCoreExpr sty pbdr1 pbdr2 pocc expr - = ppr_expr (initial_pe sty (Left (pbdr1, pbdr2, pocc))) expr +pprGenCoreExpr sty pbdr1 pbdr2 pocc expr + = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr pprParendCoreExpr sty pbdr1 pbdr2 pocc expr = let @@ -120,16 +140,16 @@ pprParendCoreExpr sty pbdr1 pbdr2 pocc expr Lit _ -> id _ -> ppParens -- wraps in parens in - parenify (pprCoreExpr sty pbdr1 pbdr2 pocc expr) + parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr) ppr_core_arg sty pocc arg - = ppr_arg (initial_pe sty (Left (pocc, pocc, pocc))) arg + = ppr_arg (init_ppr_env sty pocc pocc pocc) arg ppr_core_alts sty pbdr1 pbdr2 pocc alts - = ppr_alts (initial_pe sty (Left (pbdr1, pbdr2, pocc))) alts + = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts ppr_core_default sty pbdr1 pbdr2 pocc deflt - = ppr_default (initial_pe sty (Left (pbdr1, pbdr2, pocc))) deflt + = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt \end{code} %************************************************************************ @@ -144,14 +164,14 @@ instance Eq uvar, Outputable uvar) => Outputable (GenCoreBinding bndr occ tyvar uvar) where - ppr sty bind = pprCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind + ppr sty bind = pprGenCoreBinding 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 + ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr instance (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) @@ -176,126 +196,13 @@ instance %************************************************************************ %* * -\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]) + = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) 4 (ppr_expr pe expr) ppr_bind pe (Rec binds) @@ -304,7 +211,7 @@ ppr_bind pe (Rec binds) ppStr "{- end Rec -}" ] where ppr_pair (val_bdr, expr) - = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals]) + = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) 4 (ppr_expr pe expr) \end{code} @@ -321,25 +228,25 @@ ppr_parend_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 (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 '!']) + = 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 '!']) + = ppHang (ppBesides [pPrim pe prim, ppChar '!']) 4 (ppSep (map (ppr_arg pe) args)) ppr_expr pe expr@(Lam _ _) = let (uvars, tyvars, vars, body) = collectBinders expr in - ppHang (ppCat [pp_vars SLIT("_/u\\_") (puvar pe) uvars, - pp_vars SLIT("_/\\_") (ptyvar pe) tyvars, - pp_vars SLIT("\\") (pmin_bdr pe) vars]) + ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar pe) uvars, + pp_vars SLIT("_/\\_") (pTyVar pe) tyvars, + pp_vars SLIT("\\") (pMinBndr pe) vars]) 4 (ppr_expr pe body) where pp_vars lam pp [] = ppNil @@ -348,10 +255,13 @@ ppr_expr pe expr@(Lam _ _) ppr_expr pe expr@(App _ _) = let - (fun, args) = collectArgs expr + (fun, uargs, targs, vargs) = collectArgs expr in ppHang (ppr_parend_expr pe fun) - 4 (ppSep (map (ppr_arg pe) args)) + 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs) + , ppInterleave ppNil (map (pTy pe) targs) + , ppInterleave ppNil (map (ppr_arg pe) vargs) + ]) ppr_expr pe (Case expr alts) = ppSep @@ -364,7 +274,7 @@ ppr_expr pe (Case expr alts) ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = ppAboves [ - ppCat [ppStr "let {", pmaj_bdr pe val_bdr, ppEquals], + ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals], ppNest 2 (ppr_expr pe rhs), ppStr "} in", ppr_expr pe body ] @@ -372,7 +282,7 @@ ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) 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]) + 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) 4 (ppr_expr pe rhs), ppStr "} in"])) (ppr_expr pe expr) @@ -383,7 +293,7 @@ ppr_expr pe (Let bind expr) ppHang (ppStr "} in ") 2 (ppr_expr pe expr)] ppr_expr pe (SCC cc expr) - = ppSep [ppCat [ppPStr SLIT("_scc_"), pscc pe cc], + = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc], ppr_parend_expr pe expr ] \end{code} @@ -392,8 +302,8 @@ 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), + = ppHang (ppCat [ppr_con con (pCon pe con), + ppInterleave ppSP (map (pMinBndr pe) params), ppStr "->"]) 4 (ppr_expr pe expr) where @@ -404,7 +314,7 @@ 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 "->"]) + = ppHang (ppCat [pLit pe lit, ppStr "->"]) 4 (ppr_expr pe expr) \end{code} @@ -412,15 +322,15 @@ ppr_alts pe (PrimAlts alts deflt) ppr_default pe NoDefault = ppNil ppr_default pe (BindDefault val_bdr expr) - = ppHang (ppCat [pmin_bdr pe val_bdr, ppStr "->"]) + = ppHang (ppCat [pMinBndr 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 +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@ diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 4db1bdf..1e29075 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -34,21 +34,23 @@ start. deSugar :: UniqSupply -- name supply -> FAST_STRING -- module name - -> (TypecheckedHsBinds, -- input: class, instance, and value - TypecheckedHsBinds, -- bindings; see "tcModule" (which produces + -> (TypecheckedHsBinds, -- input: recsel, class, instance, and value + TypecheckedHsBinds, -- bindings; see "tcModule" (which produces TypecheckedHsBinds, -- them) + TypecheckedHsBinds, [(Id, TypecheckedHsExpr)]) -- ToDo: handling of const_inst thingies is certainly WRONG *************************** -> ([CoreBinding], -- output Bag DsMatchContext) -- Shadowing complaints -deSugar us mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs) +deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs) = let (us0, us0a) = splitUniqSupply us (us1, us1a) = splitUniqSupply us0a (us2, us2a) = splitUniqSupply us1a - (us3, us4) = splitUniqSupply us2a + (us3, us3a) = splitUniqSupply us2a + (us4, us5) = splitUniqSupply us3a ((core_const_prs, consts_pairs), shadows1) = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs) @@ -67,21 +69,28 @@ deSugar us mod_name (clas_binds, inst_binds, val_binds, const_inst_pairs) = initDs us3 consts_env mod_name (dsBinds val_binds) core_val_pairs = pairsFromCoreBinds core_val_binds + (core_recsel_binds, shadows5) + = initDs us4 consts_env mod_name (dsBinds recsel_binds) + core_recsel_prs = pairsFromCoreBinds core_recsel_binds + final_binds - = if (null core_clas_prs && null core_inst_prs && null core_const_prs) then + = if (null core_clas_prs && null core_inst_prs + && null core_recsel_prs {-???dont know???-} && null core_const_prs) then -- we don't have to make the whole thing recursive core_clas_binds ++ core_val_binds else -- gotta make it recursive (sigh) - [Rec (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 ++ core_recsel_prs)] - lift_final_binds = liftCoreBindings us4 final_binds + lift_final_binds = liftCoreBindings us5 final_binds really_final_binds = if opt_DoCoreLinting then lintCoreBindings PprDebug "Desugarer" False lift_final_binds else lift_final_binds - shadows = shadows1 `unionBags` shadows2 `unionBags` shadows3 `unionBags` shadows4 + shadows = shadows1 `unionBags` shadows2 `unionBags` + shadows3 `unionBags` shadows4 `unionBags` shadows5 in (really_final_binds, shadows) \end{code} diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index bc26cf4..ec1bdd4 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -31,14 +31,13 @@ import CoreUtils ( escErrorMsg ) import CostCentre ( mkAllDictsCC, preludeDictsCostCentre ) import Id ( idType, DictVar(..), GenId ) import ListSetOps ( minusList, intersectLists ) -import PprType ( GenType, GenTyVar ) +import PprType ( GenType ) import PprStyle ( PprStyle(..) ) import Pretty ( ppShow ) import Type ( mkTyVarTys, splitSigmaTy, tyVarsOfType, tyVarsOfTypes ) -import TyVar ( tyVarSetToList, GenTyVar ) -import Unique ( Unique ) +import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} ) import Util ( isIn, panic ) isDictTy = panic "DsBinds.isDictTy" @@ -290,35 +289,28 @@ dsInstBinds :: [TyVar] -- Abstract wrt these do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh) prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto -dsInstBinds tyvars [] - = returnDs do_nothing - -dsInstBinds _ _ = panic "DsBinds.dsInstBinds:maybe we want something different?" - -{- LATER +dsInstBinds tyvars [] = returnDs do_nothing dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs) - = dsExpr expr `thenDs` ( \ rhs -> + = dsExpr expr `thenDs` \ rhs -> let -- Need to apply dsExpr to the variable in case it -- has a substitution in the current environment subst_item = (inst, rhs) in extendEnvDs [subst_item] ( dsInstBinds tyvars bs - ) `thenDs` (\ (binds, subst_env) -> + ) `thenDs` \ (binds, subst_env) -> returnDs (binds, subst_item : subst_env) - )) dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs) - = dsExpr expr `thenDs` ( \ core_lit -> + = dsExpr expr `thenDs` \ core_lit -> let subst_item = (inst, core_lit) in extendEnvDs [subst_item] ( dsInstBinds tyvars bs - ) `thenDs` (\ (binds, subst_env) -> + ) `thenDs` \ (binds, subst_env) -> returnDs (binds, subst_item : subst_env) - )) dsInstBinds tyvars ((inst, expr) : bs) | null abs_tyvars @@ -351,7 +343,7 @@ dsInstBinds tyvars ((inst, expr) : bs) subst_item : subst_env) where inst_ty = idType inst - abs_tyvars = tyVarsOfType inst_ty `intersectLists` tyvars + abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars abs_tys = mkTyVarTys abs_tyvars (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty @@ -359,26 +351,23 @@ dsInstBinds tyvars ((inst, expr) : bs) -- Wrap a desugared expression in `_scc_ "DICT" ' if -- appropriate. Uses "inst"'s type. + -- if profiling, wrap the dict in "_scc_ DICT ": ds_dict_cc expr - = -- if profiling, wrap the dict in "_scc_ DICT ": - let - 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 (SCC prel_dicts_cc expr) - else - getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) -> + | not opt_SccProfilingOn || + not (isDictTy inst_ty) + = returnDs expr -- that's easy: do nothing + + | opt_CompilingPrelude + = returnDs (SCC prel_dicts_cc expr) + + | otherwise + = getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) -> -- ToDo: do -dicts-all flag (mark dict things -- with individual CCs) - let + let dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-} - in - returnDs (SCC dict_cc expr) --} + in + returnDs (SCC dict_cc expr) \end{code} %************************************************************************ diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index f2eb50b..b54e111 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -19,7 +19,7 @@ import CoreUtils ( coreExprType ) import Id ( getInstantiatedDataConSig, mkTupleCon ) import Maybes ( maybeToBool ) import PprStyle ( PprStyle(..) ) -import PprType ( GenType{-instances-}, GenTyVar{-instance-} ) +import PprType ( GenType{-instances-} ) import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo, packStringForCId, realWorldStatePrimTy, realWorldStateTy, realWorldTy, stateDataCon, @@ -27,9 +27,7 @@ import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo, import Pretty import PrimOp ( PrimOp(..) ) import Type ( isPrimType, maybeAppDataTyCon, eqTy ) -import TyVar ( GenTyVar{-instance-} ) -import Unique ( Unique{-instances-} ) -import Util ( pprPanic, panic ) +import Util ( pprPanic, pprError, panic ) maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType" \end{code} @@ -198,7 +196,8 @@ we decide what's happening with enumerations. ADR (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys can't_see_datacons_error thing ty - = error (ppShow 100 (ppBesides [ppStr "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ ", ppStr thing, ppStr "; type: ", ppr PprForUser ty])) + = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ " + (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty]) \end{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 5d36347..0888099 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -32,17 +32,15 @@ import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv, import Literal ( mkMachInt, Literal(..) ) import MagicUFs ( MagicUnfoldingFun ) import PprStyle ( PprStyle(..) ) -import PprType ( GenType, GenTyVar ) +import PprType ( GenType ) import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon, charDataCon, charTy ) -import Pretty ( ppShow ) -import Type ( splitSigmaTy ) -import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar ) -import Unique ( Unique ) +import Pretty ( ppShow, ppBesides, ppPStr, ppStr ) +import Type ( splitSigmaTy, typePrimRep ) +import TyVar ( nullTyVarEnv, addOneToTyVarEnv ) import Usage ( UVar(..) ) -import Util ( panic ) +import Util ( pprError, panic ) -primRepFromType = panic "DsExpr.primRepFromType" maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType" splitTyArgs = panic "DsExpr.splitTyArgs" @@ -103,8 +101,8 @@ dsExpr (HsLitOut (HsString s) _) -- "str" ==> build (\ c n -> foldr charTy T c n "str") {- LATER: -dsExpr (HsLitOut (HsString str) _) = - newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] -> +dsExpr (HsLitOut (HsString str) _) + = newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] -> let new_ty = mkTyVarTy new_tyvar in @@ -132,10 +130,11 @@ dsExpr (HsLitOut (HsLitLit s) ty) 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, primRepFromType prim_ty) + -> (boxing_data_con, typePrimRep prim_ty) + Nothing + -> pprError "ERROR: ``literal-literal'' not a single-constructor type: " + (ppBesides [ppPStr s, ppStr "; type: ", ppr PprDebug ty]) dsExpr (HsLitOut (HsInt i) _) = returnDs (Lit (NoRepInteger i)) @@ -317,6 +316,9 @@ dsExpr (ArithSeqOut expr (FromThenTo from thn two)) mkAppDs expr2 [] [from2, thn2, two2] \end{code} + +Type lambda and application +~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} dsExpr (TyLam tyvars expr) = dsExpr expr `thenDs` \ core_expr -> @@ -325,6 +327,31 @@ dsExpr (TyLam tyvars expr) dsExpr expr@(TyApp e tys) = dsApp expr [] \end{code} + +Record construction and update +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} +{- +dsExpr (RecordCon con_expr rbinds) + = dsExpr con_expr `thenDs` \ con_expr' -> + let + con_args = map mk_arg (arg_tys `zip` fieldLabelTags) + (arg_tys, data_ty) = splitFunTy (coreExprType con_expr') + + mk_arg (arg_ty, tag) = case [ | (sel_id,rhs) <- rbinds, + fieldLabelTag (recordSelectorFieldLabel sel_id) == tag + ] of + (rhs:rhss) -> ASSERT( null rhss ) + dsExpr rhs + + [] -> returnDs ......GONE HOME!>>>>> + + mkAppDs con_expr [] con_args +-} +\end{code} + +Dictionary lambda and application +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @DictLam@ and @DictApp@ turn into the regular old things. (OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more complicated; reminiscent of fully-applied constructors. diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 5287b22..d90e330 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -16,20 +16,17 @@ import HsSyn ( GRHSsAndBinds(..), GRHS(..), import TcHsSyn ( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..), TypecheckedPat(..), TypecheckedHsBinds(..), TypecheckedHsExpr(..) ) -import CoreSyn ( CoreBinding(..), CoreExpr(..) ) +import CoreSyn ( CoreBinding(..), CoreExpr(..), mkCoLetsAny ) import DsMonad import DsUtils -import CoreUtils ( escErrorMsg, mkErrorApp ) +import CoreUtils ( escErrorMsg, mkErrorApp, mkCoreIfThenElse ) 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. diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 636ebf4..6d9dc55 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -31,24 +31,21 @@ import CmdLineOpts ( opt_SccGroup ) import CoreSyn ( CoreExpr(..) ) import CoreUtils ( substCoreExpr ) import HsSyn ( OutPat ) -import Id ( mkSysLocal, lookupIdEnv, growIdEnvList, GenId, IdEnv(..) ) +import Id ( mkSysLocal, mkIdWithNewUniq, + lookupIdEnv, growIdEnvList, GenId, IdEnv(..) + ) import PprType ( GenType, GenTyVar ) import PprStyle ( PprStyle(..) ) import Pretty import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc ) import TcHsSyn ( TypecheckedPat(..) ) -import TyVar ( nullTyVarEnv, GenTyVar ) +import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} ) 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 @@ -165,7 +162,7 @@ newTyVarsDs :: [TyVar] -> DsM [TyVar] newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns = case (getUniques (length tyvar_tmpls) us) of { uniqs -> - (zipWithEqual cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) } + (zipWithEqual cloneTyVar tyvar_tmpls uniqs, warns) } \end{code} We can also reach out and either set/grab location information from diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 07cbe0b..700db9e 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -42,12 +42,12 @@ import PrelInfo ( stringTy ) import Id ( idType, getInstantiatedDataConSig, mkTupleCon, DataCon(..), DictVar(..), Id(..), GenId ) import TyCon ( mkTupleTyCon ) -import Type ( mkTyVarTys, mkRhoTy, mkFunTys, - applyTyCon, getAppDataTyCon ) +import Type ( mkTyVarTys, mkRhoTy, mkFunTys, isUnboxedType, + 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" @@ -228,7 +228,7 @@ dsExprToAtom arg_expr continue_with newSysLocalDs ty `thenDs` \ arg_id -> continue_with (VarArg arg_id) `thenDs` \ body -> returnDs ( - if isUnboxedDataType ty + if isUnboxedType ty then Case arg_expr (PrimAlts [] (BindDefault arg_id body)) else Let (NonRec arg_id arg_expr) body ) @@ -537,7 +537,7 @@ mkFailurePair :: Type -- Result type of the whole case expression CoreExpr) -- Either the fail variable, or fail variable -- applied to unit tuple mkFailurePair ty - | isUnboxedDataType ty + | isUnboxedType ty = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var -> newSysLocalDs unit_ty `thenDs` \ fail_fun_arg -> returnDs (\ body -> diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index f657e96..c7d0b5d 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -25,9 +25,13 @@ import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import CoreUtils ( escErrorMsg, mkErrorApp ) -import Id ( idType, mkTupleCon, GenId{-instance-} ) +import FieldLabel ( allFieldLabelTags, fieldLabelTag ) +import Id ( idType, mkTupleCon, dataConSig, + recordSelectorFieldLabel, + GenId{-instance-} + ) import PprStyle ( PprStyle(..) ) -import PprType ( GenTyVar{-instance-}, GenType{-instance-} ) +import PprType ( GenType{-instance-}, GenTyVar{-ditto-} ) import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy, charTy, charDataCon, intTy, intDataCon, floatTy, floatDataCon, doubleTy, doubleDataCon, @@ -35,10 +39,12 @@ import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy, floatPrimTy, doublePrimTy, stringTy, addrTy, addrPrimTy, addrDataCon, wordTy, wordPrimTy, wordDataCon ) -import Type ( isPrimType, eqTy ) -import TyVar ( GenTyVar ) -import Unique ( Unique ) -import Util ( panic, pprPanic ) +import Type ( isPrimType, eqTy, getAppDataTyCon, + instantiateTauTy + ) +import TyVar ( GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instance Eq-} ) +import Util ( panic, pprPanic, assertPanic ) \end{code} The function @match@ is basically the same as in the Wadler chapter, @@ -320,6 +326,27 @@ tidy1 v (LazyPat pat) match_result tidy1 v (ConOpPat pat1 id pat2 ty) match_result = returnDs (ConPat id ty [pat1, pat2], match_result) +tidy1 v (RecPat con_id pat_ty rpats) match_result + = returnDs (ConPat con_id pat_ty pats, match_result) + where + pats = map mk_pat tagged_arg_tys + + -- Boring stuff to find the arg-tys of the constructor + (tyvars, _, arg_tys, _) = dataConSig con_id + (_, inst_tys, _) = getAppDataTyCon pat_ty + tenv = tyvars `zip` inst_tys + con_arg_tys' = map (instantiateTauTy tenv) arg_tys + tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags + + -- mk_pat picks a WildPat of the appropriate type for absent fields, + -- and the specified pattern for present fields + mk_pat (arg_ty, tag) = case [pat | (sel_id,pat,_) <- rpats, + fieldLabelTag (recordSelectorFieldLabel sel_id) == tag + ] of + (pat:pats) -> ASSERT( null pats ) + pat + [] -> WildPat arg_ty + tidy1 v (ListPat ty pats) match_result = returnDs (list_ConPat, match_result) where diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 52bb3a6..1ae29da 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -75,7 +75,7 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps 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???") + MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???") mk_core_lit ty other = panic "matchLiterals:mk_core_lit:unhandled" \end{code} diff --git a/ghc/compiler/deforest/Core2Def.lhs b/ghc/compiler/deforest/Core2Def.lhs index 25c5d31..b6bfea9 100644 --- a/ghc/compiler/deforest/Core2Def.lhs +++ b/ghc/compiler/deforest/Core2Def.lhs @@ -95,8 +95,8 @@ ToDo: > 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)) ( -> Let (NonRec v (c2d p e)) (c2d p e')) +> pprTrace "Not inlining ManyOcc " (ppr PprDebug v) $ +> Let (NonRec v (c2d p e)) (c2d p e') > > Let (NonRec (v,DeadCode) e) e' -> > panic "Core2Def(c2d): oops, unexpected DeadCode" @@ -104,8 +104,8 @@ ToDo: > 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))( -> Let (NonRec v (c2d p e)) (c2d p e')) +> pprTrace "Not inlining DupDanger " (ppr PprDebug v) $ +> Let (NonRec v (c2d p e)) (c2d p e') > | isFun fun_or_arg -> > panic "Core2Def(c2d): oops, unexpected Macro" > | otherwise -> inline_it diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs index 08b65d7..48cde68 100644 --- a/ghc/compiler/deforest/Cyclic.lhs +++ b/ghc/compiler/deforest/Cyclic.lhs @@ -165,8 +165,7 @@ Comment the next section out to disable back-loops. > if not (null back_loops){- && not (f `elem` ls')-} then > --if length back_loops > 1 then panic "barf!" else > d2c (head back_loops) `thenUs` \core_e -> -> trace ("Back Loop:\n" ++ -> ppShow 80 (ppr PprDebug core_e)) $ +> pprTrace "Back Loop:\n" (ppr PprDebug core_e) $ If we find a back-loop that also occurs where we would normally make a new function... diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index a01b198..51446f2 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -25,10 +25,9 @@ import HsTypes ( PolyType ) --others: import Id ( DictVar(..), Id(..), GenId ) import Outputable -import PprType ( pprType ) import Pretty import SrcLoc ( SrcLoc{-instances-} ) -import TyVar ( GenTyVar{-instances-} ) +--import TyVar ( GenTyVar{-instances-} ) \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index dad1f52..18f817a 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -161,7 +161,7 @@ data ConDecl name SrcLoc | RecConDecl name - [(name, BangType name)] -- list of "fields" + [([name], BangType name)] -- list of "fields" SrcLoc | NewConDecl name -- newtype con decl diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 2004ddf..fc9356a 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -20,13 +20,11 @@ import HsTypes ( PolyType ) -- others: import Id ( DictVar(..), GenId, Id(..) ) import Outputable -import PprType ( pprType, pprParendType, GenType{-instance-}, GenTyVar{-instance-} ) +import PprType ( pprGenType, pprParendGenType, GenType{-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} @@ -99,11 +97,14 @@ data HsExpr tyvar uvar id pat -- for tuples, we can get the types -- direct from the components - | RecordCon id -- record construction - [(id, Maybe (HsExpr tyvar uvar id pat))] + -- Record construction + | RecordCon (HsExpr tyvar uvar id pat) -- Always (HsVar id) until type checker, + -- but the latter adds its type args too + (HsRecordBinds tyvar uvar id pat) - | RecordUpd (HsExpr tyvar uvar id pat) -- record update - [(id, Maybe (HsExpr tyvar uvar id pat))] + -- Record update + | RecordUpd (HsExpr tyvar uvar id pat) + (HsRecordBinds tyvar uvar id pat) | ExprWithTySig -- signature binding (HsExpr tyvar uvar id pat) @@ -160,6 +161,11 @@ Everything from here on appears only in typechecker output. | SingleDict -- a simple special case of Dictionary id -- local dictionary name + +type HsRecordBinds tyvar uvar id pat + = [(id, HsExpr tyvar uvar id pat, Bool)] + -- True <=> source code used "punning", + -- i.e. {op1, op2} rather than {op1=e1, op2=e2} \end{code} A @Dictionary@, unless of length 0 or 1, becomes a tuple. A @@ -272,7 +278,7 @@ 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))) ] + ifnotPprForUser sty (ppBeside ppSP (ppParens (pprGenType sty ty))) ] pprExpr sty (ExplicitTuple exprs) = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs)) @@ -300,7 +306,7 @@ pprExpr sty (TyLam tyvars expr) 4 (pprExpr sty expr) pprExpr sty (TyApp expr [ty]) - = ppHang (pprExpr sty expr) 4 (pprParendType sty ty) + = ppHang (pprExpr sty expr) 4 (pprParendGenType sty ty) pprExpr sty (TyApp expr tys) = ppHang (pprExpr sty expr) @@ -360,16 +366,17 @@ pprParendExpr sty expr %************************************************************************ \begin{code} +pp_rbinds :: (NamedThing id, Outputable id, Outputable pat, + Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) + => PprStyle -> Pretty + -> HsRecordBinds tyvar uvar id pat -> Pretty + 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] + where + pp_rbind sty (v, _, True{-pun-}) = ppr sty v + pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "<-", ppr sty e] \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 4c8186f..b257cd3 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -17,8 +17,6 @@ import Outputable ( ifPprShowAll ) import PprType import Pretty import SrcLoc ( SrcLoc{-instances-} ) -import TyVar ( GenTyVar{-instances-} ) -import Unique ( Unique{-instances-} ) import Util ( panic ) \end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 73124ac..11e4d26 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -24,16 +24,13 @@ import HsLit ( HsLit ) import HsLoop ( HsExpr ) -- others: -import Id ( GenId, getDataConSig ) +import Id ( GenId, dataConSig ) import Maybes ( maybeToBool ) import Outputable import PprStyle ( PprStyle(..) ) import Pretty import TyCon ( maybeTyConSingleCon ) -import TyVar ( GenTyVar ) -import PprType ( GenType, GenTyVar ) -import Unique ( Unique ) - +import PprType ( GenType ) \end{code} Patterns come in distinct before- and after-typechecking flavo(u)rs. @@ -55,7 +52,7 @@ data InPat name | TuplePatIn [InPat name] -- tuple | RecPatIn name -- record - [(name, Maybe (InPat name))] + [(name, InPat name, Bool)] -- True <=> source used punning data OutPat tyvar uvar id = WildPat (GenType tyvar uvar) -- wild card @@ -82,8 +79,9 @@ data OutPat tyvar uvar id | TuplePat [(OutPat tyvar uvar id)] -- tuple -- UnitPat is TuplePat [] - | RecPat id -- record - [(id, Maybe (OutPat tyvar uvar id))] + | RecPat Id -- record constructor + (GenType tyvar uvar) -- the type of the pattern + [(id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning | LitPat -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. @@ -137,8 +135,8 @@ pprInPat sty (TuplePatIn pats) 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] + pp_rpat (v, _, True{-pun-}) = ppr sty v + pp_rpat (v, p, _) = ppCat [ppr sty v, ppStr "<-", ppr sty p] \end{code} \begin{code} @@ -172,11 +170,11 @@ pprOutPat sty (ListPat ty pats) pprOutPat sty (TuplePat pats) = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] -pprOutPat sty (RecPat con rpats) +pprOutPat sty (RecPat con ty 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] +-- pp_rpat (v, _, True{-pun-}) = ppr sty v + pp_rpat (v, 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 @@ -266,7 +264,7 @@ irrefutablePat other_pat = False -- Literals, NPat only_con con = maybeToBool (maybeTyConSingleCon tycon) where - (_,_,_,tycon) = getDataConSig con + (_,_,_,tycon) = dataConSig con \end{code} This function @collectPatBinders@ works with the ``collectBinders'' diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index d455ff0..d588f68 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -10,10 +10,7 @@ module ErrUtils ( Error(..), addErrLoc, addShortErrLocLine, - dontAddErrLoc, pprBagOfErrors, - - TcError(..), TcWarning(..), Message(..), - mkTcErr, arityErr + dontAddErrLoc, pprBagOfErrors ) where @@ -51,33 +48,3 @@ pprBagOfErrors sty bag_of_errors 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]) - - -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} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index c691844..7e84618 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -19,15 +19,27 @@ import ReadPrefix ( rdModule ) import Rename ( renameModule ) import Typecheck ( typecheckModule, InstInfo ) import Desugar ( deSugar, DsMatchContext, pprDsWarnings ) +import SimplCore ( core2core ) +import CoreToStg ( topCoreBindsToStg ) +import SimplStg ( stg2stg ) +import CodeGen ( codeGen ) +#if ! OMIT_NATIVE_CODEGEN +import AsmCodeGen ( dumpRealAsm, writeRealAsm ) +#endif +import AbsCSyn ( absCNop, AbstractC ) +import AbsCUtils ( flattenAbsC ) import Bag ( emptyBag, isEmptyBag ) import CmdLineOpts import ErrUtils ( pprBagOfErrors ) -import Maybes ( MaybeErr(..) ) +import Maybes ( maybeToBool, MaybeErr(..) ) import PrelInfo ( builtinNameInfo ) import RdrHsSyn ( getRawExportees ) +import Specialise ( SpecialiseData(..) ) +import StgSyn ( pprPlainStgBinding, GenStgBinding ) -import PprCore ( pprPlainCoreBinding ) +import PprAbsC ( dumpRealC, writeRealC ) +import PprCore ( pprCoreBinding ) import PprStyle ( PprStyle(..) ) import Pretty @@ -39,20 +51,8 @@ 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 MkIface ( mkInterface ) -#if ! OMIT_NATIVE_CODEGEN ---import AsmCodeGen ( dumpRealAsm, writeRealAsm ) -#endif -} \end{code} @@ -153,12 +153,13 @@ doIt (core_cmds, stg_cmds) input_pgm else ( -- No typechecking errors ... case tc_results - of { (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds), + of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds), interface_stuff@(_,_,_,_,_), -- @-pat just for strictness... (local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) -> doDump opt_D_dump_tc "Typechecked:" (pp_show (ppAboves [ + ppr pprStyle recsel_binds, ppr pprStyle class_binds, ppr pprStyle inst_binds, ppAboves (map (\ (i,e) -> ppr pprStyle (VarMonoBind i e)) const_binds), @@ -167,12 +168,11 @@ doIt (core_cmds, stg_cmds) input_pgm doDump opt_D_dump_deriv "Derived instances:" (pp_show (ddump_deriv pprStyle)) `thenMn_` - -- ******* DESUGARER show_pass "DeSugar" `thenMn_` let (desugared,ds_warnings) - = deSugar ds_uniqs ds_mod_name typechecked_quad + = deSugar ds_uniqs ds_mod_name typechecked_quint in (if isEmptyBag ds_warnings then returnMn () @@ -182,13 +182,11 @@ doIt (core_cmds, stg_cmds) input_pgm ) `thenMn_` doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves - (map (pprPlainCoreBinding pprStyle) desugared))) + (map (pprCoreBinding pprStyle) desugared))) `thenMn_` -{- LATER ... - -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op) - core2core core_cmds switch_lookup_fn co_mod_name pprStyle + core2core core_cmds co_mod_name pprStyle sm_uniqs local_tycons pragma_tycon_specs desugared `thenMn` @@ -196,7 +194,7 @@ doIt (core_cmds, stg_cmds) input_pgm SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) -> doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves - (map (pprPlainCoreBinding pprStyle) simplified))) + (map (pprCoreBinding pprStyle) simplified))) `thenMn_` -- ******* STG-TO-STG SIMPLIFICATION @@ -206,7 +204,7 @@ doIt (core_cmds, stg_cmds) input_pgm in show_pass "Stg2Stg" `thenMn_` - stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds + stg2stg stg_cmds st_mod_name pprStyle st_uniqs stg_binds `thenMn` \ (stg_binds2, cost_centre_info) -> @@ -215,6 +213,7 @@ doIt (core_cmds, stg_cmds) input_pgm (pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2))) `thenMn_` +{- LATER ... -- ******* INTERFACE GENERATION (needs STG output) {- let mod_name = "_TestName_" @@ -227,17 +226,19 @@ doIt (core_cmds, stg_cmds) input_pgm if_inst_info = emptyBag in -} + show_pass "Interface" `thenMn_` let mod_interface - = mkInterface switch_is_on if_mod_name export_list_fns + = mkInterface if_mod_name export_list_fns inlinings_env all_tycon_specs interface_stuff stg_binds2 in - doOutput ProduceHi ( \ file -> + doOutput opt_ProduceHi ( \ file -> ppAppendFile file 1000{-pprCols-} mod_interface ) `thenMn_` +-} -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C! show_pass "CodeGen" `thenMn_` @@ -245,7 +246,6 @@ doIt (core_cmds, stg_cmds) input_pgm 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 @@ -253,42 +253,40 @@ doIt (core_cmds, stg_cmds) input_pgm flat_abstractC = flattenAbsC fl_uniqs abstractC in doDump opt_D_dump_absC "Abstract C:" - (dumpRealC switch_is_on abstractC) `thenMn_` + (dumpRealC abstractC) `thenMn_` doDump opt_D_dump_flatC "Flat Abstract C:" - (dumpRealC switch_is_on flat_abstractC) `thenMn_` + (dumpRealC 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 -- flat_abstractC. WDP 94/10] let (flat_absC_c, flat_absC_ncg) = - case (string_switch_is_on ProduceC || switch_is_on D_dump_realC, - string_switch_is_on ProduceS || switch_is_on D_dump_asm) of - (True, False) -> (flat_abstractC, AbsCNop) - (False, True) -> (AbsCNop, flat_abstractC) - (False, False) -> (AbsCNop, AbsCNop) + case (maybeToBool opt_ProduceC || opt_D_dump_realC, + maybeToBool opt_ProduceS || opt_D_dump_asm) of + (True, False) -> (flat_abstractC, absCNop) + (False, True) -> (absCNop, flat_abstractC) + (False, False) -> (absCNop, absCNop) (True, True) -> error "ERROR: Can't do both .hc and .s at the same time" - c_output_d = dumpRealC switch_is_on flat_absC_c - c_output_w = (\ f -> writeRealC switch_is_on f flat_absC_c) + c_output_d = dumpRealC flat_absC_c + c_output_w = (\ f -> writeRealC f flat_absC_c) #if OMIT_NATIVE_CODEGEN ncg_output_d = error "*** GHC not built with a native-code generator ***" ncg_output_w = ncg_output_d #else - 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) + ncg_output_d = dumpRealAsm flat_absC_ncg ncg_uniqs + ncg_output_w = (\ f -> writeRealAsm f flat_absC_ncg ncg_uniqs) #endif in doDump opt_D_dump_asm "" ncg_output_d `thenMn_` - doOutput ProduceS ncg_output_w `thenMn_` + doOutput opt_ProduceS ncg_output_w `thenMn_` doDump opt_D_dump_realC "" c_output_d `thenMn_` - doOutput ProduceC c_output_w `thenMn_` - -LATER -} + doOutput opt_ProduceC c_output_w `thenMn_` exitMn 0 } ) } } } where @@ -319,8 +317,8 @@ LATER -} doOutput switch io_action = case switch of - Nothing -> returnMn () - Just fname -> + Nothing -> returnMn () + Just fn -> let fname = _UNPK_ fn in fopen fname "a+" `thenPrimIO` \ file -> if (file == ``NULL'') then error ("doOutput: failed to open:"++fname) @@ -333,8 +331,8 @@ LATER -} doDump switch hdr string = if switch - then writeMn stderr hdr `thenMn_` - writeMn stderr ('\n': string) `thenMn_` + then writeMn stderr hdr `thenMn_` + writeMn stderr ('\n': string) `thenMn_` writeMn stderr "\n" else returnMn () diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 0b8de5f..46bb220 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -163,7 +163,6 @@ mkInterface modname export_list_fns inline_env tycon_specs -- mkInterface to do I/O (WDP 94/10) error "Can't produce interface file because of errors!\n" else --- trace ("mkIface:Ids:"++(ppShow 80 (ppr PprDebug global_ids))) ( ppAboves [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"), ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")], @@ -181,7 +180,6 @@ mkInterface modname export_list_fns inline_env tycon_specs ppChar '\n' ] --- ) where any_purely_local tycons classes vals = any bad_tc tycons || any bad_cl classes || any bad_id vals @@ -322,7 +320,7 @@ get_tycon_pair tycon ExportAbs -> orig_nm NotExported -> orig_nm - cons = getTyConDataCons tycon + cons = tyConDataCons tycon in (orig_mod, nm_to_print) } @@ -411,7 +409,7 @@ do_value better_id_fn inline_env val ppPStr SLIT("#-}")] in ppAbove (ppCat [ppr_non_op name_str, - ppPStr SLIT("::"), pprType sty val_ty]) + ppPStr SLIT("::"), pprGenType sty val_ty]) pp_id_info -- sadly duplicates Outputable.pprNonOp (ToDo) diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 3997048..9086343 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -1,62 +1,59 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \begin{code} #include "HsVersions.h" -module AbsCStixGen ( - genCodeAbstractC, +module AbsCStixGen ( genCodeAbstractC ) where - -- and, of course, that's not enough... - AbstractC, Target, StixTree, UniqSupply, UniqSM(..) - ) where +import Ubiq{-uitous-} import AbsCSyn -import PrelInfo ( PrimOp(..), primOpNeedsWrapper, isCompareOp - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import Stix + +import MachMisc +import MachRegs + +import AbsCUtils ( getAmodeRep, mixedTypeLocn, + nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList ) import CgCompInfo ( mIN_UPD_SIZE ) -import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, - closureUpdReqd +import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, + fastLabelFromCI, closureUpdReqd ) -import MachDesc -import Maybes ( Maybe(..), maybeToBool ) -import Outputable -import PrimRep ( isFloatingRep ) -import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) -import Stix +import HeapOffs ( hpRelToInt ) +import Literal ( Literal(..) ) +import Maybes ( maybeToBool ) +import OrdList ( OrdList ) +import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) +import PrimRep ( isFloatingRep, PrimRep(..) ) import StixInfo ( genCodeInfoTable ) -import UniqSupply -import Util +import StixMacro ( macroCode ) +import StixPrim ( primCode, amodeToStix, amodeToStix' ) +import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) ) +import Util ( naturalMergeSortLe, panic ) \end{code} -For each independent chunk of AbstractC code, we generate a list of @StixTree@s, -where each tree corresponds to a single Stix instruction. We leave the chunks -separated so that register allocation can be performed locally within the chunk. +For each independent chunk of AbstractC code, we generate a list of +@StixTree@s, where each tree corresponds to a single Stix instruction. +We leave the chunks separated so that register allocation can be +performed locally within the chunk. \begin{code} --- hacking with Uncle Will: -#define target_STRICT target@(Target _ _ _ _ _ _ _ _) +genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]] -genCodeAbstractC - :: Target - -> AbstractC - -> UniqSM [[StixTree]] - -genCodeAbstractC target_STRICT absC = - mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees -> +genCodeAbstractC absC + = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees -> returnUs ([StComment SLIT("Native Code")] : trees) where - -- "target" munging things... --- - a2stix = amodeToStix target - a2stix' = amodeToStix' target - volsaves = volatileSaves target - volrestores = volatileRestores target - p2stix = primToStix target - macro_code = macroCode target - hp_rel = hpRel target + a2stix = amodeToStix + a2stix' = amodeToStix' + volsaves = volatileSaves + volrestores = volatileRestores + p2stix = primCode + macro_code = macroCode + hp_rel = hpRelToInt -- real code follows... --------- \end{code} @@ -66,34 +63,33 @@ Here we handle top-level things, like @CCodeBlock@s and \begin{code} {- genCodeTopAbsC - :: Target - -> AbstractC + :: AbstractC -> UniqSM [StixTree] -} - gentopcode (CCodeBlock label absC) = - gencode absC `thenUs` \ code -> + gentopcode (CCodeBlock label absC) + = gencode absC `thenUs` \ code -> returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label]) - gentopcode stmt@(CStaticClosure label _ _ _) = - genCodeStaticClosure stmt `thenUs` \ code -> + gentopcode stmt@(CStaticClosure label _ _ _) + = genCodeStaticClosure stmt `thenUs` \ code -> returnUs (StSegment DataSegment : StLabel label : code []) gentopcode stmt@(CRetUnVector _ _) = returnUs [] - gentopcode stmt@(CFlatRetVector label _) = - genCodeVecTbl stmt `thenUs` \ code -> + gentopcode stmt@(CFlatRetVector 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 `thenUs` \ itbl -> + = genCodeInfoTable stmt `thenUs` \ itbl -> returnUs (StSegment TextSegment : itbl []) | otherwise - = genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl -> - gencode slow `thenUs` \ slow_code -> + = genCodeInfoTable stmt `thenUs` \ itbl -> + gencode slow `thenUs` \ slow_code -> returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl : slow_code [StFunEnd slow_lbl])) where @@ -102,9 +98,9 @@ Here we handle top-level things, like @CCodeBlock@s and gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) = -- ToDo: what if this is empty? ------------------------^^^^ - genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl -> - gencode slow `thenUs` \ slow_code -> - gencode fast `thenUs` \ fast_code -> + genCodeInfoTable 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]))) @@ -112,8 +108,8 @@ Here we handle top-level things, like @CCodeBlock@s and slow_lbl = entryLabelFromCI cl_info fast_lbl = fastLabelFromCI cl_info - gentopcode absC = - gencode absC `thenUs` \ code -> + gentopcode absC + = gencode absC `thenUs` \ code -> returnUs (StSegment TextSegment : code []) \end{code} @@ -123,12 +119,11 @@ Vector tables are trivial! \begin{code} {- genCodeVecTbl - :: Target - -> AbstractC + :: AbstractC -> UniqSM StixTreeList -} - genCodeVecTbl (CFlatRetVector label amodes) = - returnUs (\xs -> vectbl : xs) + genCodeVecTbl (CFlatRetVector label amodes) + = returnUs (\xs -> vectbl : xs) where vectbl = StData PtrRep (reverse (map a2stix amodes)) @@ -139,12 +134,11 @@ Static closures are not so hard either. \begin{code} {- genCodeStaticClosure - :: Target - -> AbstractC + :: AbstractC -> UniqSM StixTreeList -} - genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes) = - returnUs (\xs -> table : xs) + genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes) + = returnUs (\xs -> table : xs) where table = StData PtrRep (StCLbl info_lbl : body) info_lbl = infoTableLabelFromCI cl_info @@ -170,8 +164,7 @@ Now the individual AbstractC statements. \begin{code} {- gencode - :: Target - -> AbstractC + :: AbstractC -> UniqSM StixTreeList -} \end{code} @@ -197,8 +190,8 @@ resulting StixTreeLists are joined together. \begin{code} - gencode (AbsCStmts c1 c2) = - gencode c1 `thenUs` \ b1 -> + gencode (AbsCStmts c1 c2) + = gencode c1 `thenUs` \ b1 -> gencode c2 `thenUs` \ b2 -> returnUs (b1 . b2) @@ -212,8 +205,8 @@ addresses, etc.) \begin{code} - gencode (CInitHdr cl_info reg_rel _ _) = - let + gencode (CInitHdr cl_info reg_rel _ _) + = let lhs = a2stix (CVal reg_rel PtrRep) lbl = infoTableLabelFromCI cl_info in @@ -232,8 +225,8 @@ of the source? Be careful about floats/doubles. gencode (CAssign lhs rhs) | getAmodeRep lhs == VoidRep = returnUs id - | otherwise = - let pk = getAmodeRep lhs + | otherwise + = let pk = getAmodeRep lhs pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk lhs' = a2stix lhs rhs' = a2stix' rhs @@ -248,23 +241,23 @@ with the address of the info table before jumping to the entry code for Node. \begin{code} - gencode (CJump dest) = - returnUs (\xs -> StJump (a2stix dest) : xs) + gencode (CJump dest) + = returnUs (\xs -> StJump (a2stix dest) : xs) - gencode (CFallThrough (CLbl lbl _)) = - returnUs (\xs -> StFallThrough lbl : xs) + gencode (CFallThrough (CLbl lbl _)) + = returnUs (\xs -> StFallThrough lbl : xs) - gencode (CReturn dest DirectReturn) = - returnUs (\xs -> StJump (a2stix dest) : xs) + gencode (CReturn dest DirectReturn) + = returnUs (\xs -> StJump (a2stix dest) : xs) - gencode (CReturn table (StaticVectoredReturn n)) = - returnUs (\xs -> StJump dest : xs) + gencode (CReturn table (StaticVectoredReturn n)) + = returnUs (\xs -> StJump dest : xs) where dest = StInd PtrRep (StIndex PtrRep (a2stix table) (StInt (toInteger (-n-1)))) - gencode (CReturn table (DynamicVectoredReturn am)) = - returnUs (\xs -> StJump dest : xs) + gencode (CReturn table (DynamicVectoredReturn am)) + = 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] @@ -277,8 +270,8 @@ Now the PrimOps, some of which may need caller-saves register wrappers. gencode (COpStmt results op args liveness_mask vols) -- ToDo (ADR?): use that liveness mask - | primOpNeedsWrapper op = - let + | primOpNeedsWrapper op + = let saves = volsaves vols restores = volrestores vols in @@ -356,11 +349,11 @@ Finally, all of the disgusting AbstractC macros. gencode (CMacroStmt macro args) = macro_code macro args - gencode (CCallProfCtrMacro macro _) = - returnUs (\xs -> StComment macro : xs) + gencode (CCallProfCtrMacro macro _) + = returnUs (\xs -> StComment macro : xs) - gencode (CCallProfCCMacro macro _) = - returnUs (\xs -> StComment macro : xs) + gencode (CCallProfCCMacro macro _) + = returnUs (\xs -> StComment macro : xs) \end{code} @@ -383,12 +376,11 @@ comparison tree. (Perhaps this could be tuned.) {- mkSimpleSwitches - :: Target - -> CAddrMode -> [(Literal,AbstractC)] -> AbstractC + :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC -> UniqSM StixTreeList -} - mkSimpleSwitches am alts absC = - getUniqLabelNCG `thenUs` \ udlbl -> + mkSimpleSwitches am alts absC + = getUniqLabelNCG `thenUs` \ udlbl -> getUniqLabelNCG `thenUs` \ ujlbl -> let am' = a2stix am joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts @@ -401,14 +393,6 @@ comparison tree. (Perhaps this could be tuned.) -- lowest and highest possible values the discriminant could take lowest = if floating then targetMinDouble else targetMinInt highest = if floating then targetMaxDouble else targetMaxInt - - -- These should come from somewhere else, depending on the target arch - -- (Note that the floating point values aren't terribly important.) - -- ToDo: Fix!(JSM) - targetMinDouble = MachDouble (-1.7976931348623157e+308) - targetMaxDouble = MachDouble (1.7976931348623157e+308) - targetMinInt = mkMachInt (-2147483647) - targetMaxInt = mkMachInt 2147483647 in ( if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then @@ -431,20 +415,20 @@ comparison tree. (Perhaps this could be tuned.) \end{code} -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 -the alternatives should lie within the indicated range. The alternatives need -not cover the range; a default target is provided for the missing alternatives. +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 the alternatives should lie within the +indicated range. The alternatives need not cover the range; a default +target is provided for the missing alternatives. -If a join is necessary after the switch, the alternatives should already finish -with a jump to the join point. +If a join is necessary after the switch, the alternatives should +already finish with a jump to the join point. \begin{code} {- mkJumpTable - :: Target - -> StixTree -- discriminant + :: StixTree -- discriminant -> [(Literal, AbstractC)] -- alternatives -> Integer -- low tag -> Integer -- high tag @@ -452,8 +436,8 @@ with a jump to the join point. -> UniqSM StixTreeList -} - mkJumpTable am alts lowTag highTag dflt = - getUniqLabelNCG `thenUs` \ utlbl -> + mkJumpTable am alts lowTag highTag dflt + = 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]) @@ -500,8 +484,7 @@ alternatives should already finish with a jump to the join point. \begin{code} {- mkBinaryTree - :: Target - -> StixTree -- discriminant + :: StixTree -- discriminant -> Bool -- floating point? -> [(Literal, AbstractC)] -- alternatives -> Int -- number of choices @@ -513,8 +496,8 @@ alternatives should already finish with a jump to the join point. mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl | rangeOfOne = gencode alt - | otherwise = - let tag' = a2stix (CLit tag) + | otherwise + = let tag' = a2stix (CLit tag) cmpOp = if floating then DoubleNeOp else IntNeOp test = StPrim cmpOp [am, tag'] cjmp = StCondJump udlbl test @@ -526,8 +509,8 @@ alternatives should already finish with a jump to the join point. 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 `thenUs` \ uhlbl -> + mkBinaryTree am floating alts choices lowTag highTag udlbl + = getUniqLabelNCG `thenUs` \ uhlbl -> let tag' = a2stix (CLit splitTag) cmpOp = if floating then DoubleGeOp else IntGeOp test = StPrim cmpOp [am, tag'] @@ -550,16 +533,15 @@ alternatives should already finish with a jump to the join point. \begin{code} {- mkIfThenElse - :: Target - -> CAddrMode -- discriminant + :: CAddrMode -- discriminant -> Literal -- tag -> AbstractC -- if-part -> AbstractC -- else-part -> UniqSM StixTreeList -} - mkIfThenElse discrim tag alt deflt = - getUniqLabelNCG `thenUs` \ ujlbl -> + mkIfThenElse discrim tag alt deflt + = getUniqLabelNCG `thenUs` \ ujlbl -> getUniqLabelNCG `thenUs` \ utlbl -> let discrim' = a2stix discrim tag' = a2stix (CLit tag) @@ -604,8 +586,8 @@ mightFallThrough absC = ft absC True ft _ if_empty = if_empty {- Old algorithm, which called nonemptyAbsC for every subexpression! ========= -fallThroughAbsC (AbsCStmts c1 c2) = - case nonemptyAbsC c2 of +fallThroughAbsC (AbsCStmts c1 c2) + = case nonemptyAbsC c2 of Nothing -> fallThroughAbsC c1 Just x -> fallThroughAbsC x fallThroughAbsC (CJump _) = False diff --git a/ghc/compiler/nativeGen/AlphaCode.lhs b/ghc/compiler/nativeGen/AlphaCode.lhs deleted file mode 100644 index 5b5069a..0000000 --- a/ghc/compiler/nativeGen/AlphaCode.lhs +++ /dev/null @@ -1,1402 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1995 -% - -\section[AlphaCode]{The Native (Alpha) Machine Code} - -\begin{code} -#include "HsVersions.h" - -module AlphaCode ( - Addr(..),Cond(..),Imm(..),RI(..),Size(..), - AlphaCode(..),AlphaInstr(..),AlphaRegs, - strImmLab, - - printLabeledCodes, - - baseRegOffset, stgRegMap, callerSaves, - - kindToSize, - - v0, f0, sp, ra, pv, gp, zero, argRegs, - - freeRegs, reservedRegs - - -- and, for self-sufficiency ... - ) where - -IMPORT_Trace - -import AbsCSyn ( MagicId(..) ) -import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..), - Reg(..), RegUsage(..), RegLiveness(..) - ) -import BitSet -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 PrimRep ( PrimRep(..) ) -import UniqSet -import Stix -import Unpretty -import Util -\end{code} - -%************************************************************************ -%* * -\subsection[AlphaReg]{The Native (Alpha) Machine Register Table} -%* * -%************************************************************************ - -The alpha has 64 registers of interest; 32 integer registers and 32 floating -point registers. The mapping of STG registers to alpha machine registers -is defined in StgRegs.h. We are, of course, prepared for any eventuality. - -\begin{code} - -fReg :: Int -> Int -fReg x = (32 + x) - -v0, f0, ra, pv, gp, sp, zero :: Reg -v0 = realReg 0 -f0 = realReg (fReg 0) -ra = FixedReg ILIT(26) -pv = t12 -gp = FixedReg ILIT(29) -sp = FixedReg ILIT(30) -zero = FixedReg ILIT(31) - -t9, t10, t11, t12 :: Reg -t9 = realReg 23 -t10 = realReg 24 -t11 = realReg 25 -t12 = realReg 27 - -argRegs :: [(Reg, Reg)] -argRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]] - -realReg :: Int -> Reg -realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i - -\end{code} - -%************************************************************************ -%* * -\subsection[TheAlphaCode]{The datatype for alpha assembly language} -%* * -%************************************************************************ - -Here is a definition of the Alpha assembly language. - -\begin{code} - -data Imm = ImmInt Int - | ImmInteger Integer -- Sigh. - | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLab Unpretty -- Simple string label - deriving () - -strImmLab s = ImmLab (uppStr s) - -data Addr = AddrImm Imm - | AddrReg Reg - | AddrRegImm Reg Imm - deriving () - -data Cond = EQ -- For CMP and BI - | LT -- For CMP and BI - | LE -- For CMP and BI - | ULT -- For CMP only - | ULE -- For CMP only - | NE -- For BI only - | GT -- For BI only - | GE -- For BI only - | ALWAYS -- For BI (same as BR) - | NEVER -- For BI (null instruction) - deriving () - -data RI = RIReg Reg - | RIImm Imm - deriving () - -data Size = B - | BU - | W - | WU - | L - | Q - | FF - | DF - | GF - | SF - | TF - deriving () - -data AlphaInstr = - --- Loads and stores. - - LD Size Reg Addr -- size, dst, src - | LDA Reg Addr -- dst, src - | LDAH Reg Addr -- dst, src - | LDGP Reg Addr -- dst, src - | LDI Size Reg Imm -- size, dst, src - | ST Size Reg Addr -- size, src, dst - --- Int Arithmetic. - - | CLR Reg -- dst - | ABS Size RI Reg -- size, src, dst - | NEG Size Bool RI Reg -- size, overflow, src, dst - | ADD Size Bool Reg RI Reg -- size, overflow, src, src, dst - | SADD Size Size Reg RI Reg -- size, scale, src, src, dst - | SUB Size Bool Reg RI Reg -- size, overflow, src, src, dst - | SSUB Size Size Reg RI Reg -- size, scale, src, src, dst - | MUL Size Bool Reg RI Reg -- size, overflow, src, src, dst - | DIV Size Bool Reg RI Reg -- size, unsigned, src, src, dst - | REM Size Bool Reg RI Reg -- size, unsigned, src, src, dst - --- Simple bit-twiddling. - - | 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 - --- Comparison - - | CMP Cond Reg RI Reg - --- Float Arithmetic. - - | 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 - --- Jumping around. - - | BI Cond Reg Imm - | BF Cond Reg Imm - | BR Imm - | JMP Reg Addr Int - | BSR Imm Int - | JSR Reg Addr Int - --- Pseudo-ops. - - | LABEL CLabel - | FUNBEGIN CLabel - | FUNEND CLabel - | COMMENT FAST_STRING - | SEGMENT CodeSegment - | ASCII Bool String -- needs backslash conversion? - | DATA Size [Imm] - -type AlphaCode = OrdList AlphaInstr - -\end{code} - -%************************************************************************ -%* * -\subsection[TheAlphaPretty]{Pretty-printing the Alpha Assembly Language} -%* * -%************************************************************************ - -\begin{code} - -printLabeledCodes :: PprStyle -> [AlphaInstr] -> Unpretty -printLabeledCodes sty codes = uppAboves (map (pprAlphaInstr sty) codes) - -\end{code} - -Printing the pieces... - -\begin{code} - -pprReg :: Reg -> Unpretty - -pprReg (FixedReg i) = pprAlphaReg i -pprReg (MappedReg i) = pprAlphaReg i -pprReg other = uppStr (show other) -- should only happen when debugging - -pprAlphaReg :: FAST_INT -> Unpretty -pprAlphaReg i = uppPStr - (case i of { - ILIT( 0) -> SLIT("$0"); ILIT( 1) -> SLIT("$1"); - ILIT( 2) -> SLIT("$2"); ILIT( 3) -> SLIT("$3"); - ILIT( 4) -> SLIT("$4"); ILIT( 5) -> SLIT("$5"); - ILIT( 6) -> SLIT("$6"); ILIT( 7) -> SLIT("$7"); - ILIT( 8) -> SLIT("$8"); ILIT( 9) -> SLIT("$9"); - ILIT(10) -> SLIT("$10"); ILIT(11) -> SLIT("$11"); - ILIT(12) -> SLIT("$12"); ILIT(13) -> SLIT("$13"); - ILIT(14) -> SLIT("$14"); ILIT(15) -> SLIT("$15"); - ILIT(16) -> SLIT("$16"); ILIT(17) -> SLIT("$17"); - ILIT(18) -> SLIT("$18"); ILIT(19) -> SLIT("$19"); - ILIT(20) -> SLIT("$20"); ILIT(21) -> SLIT("$21"); - ILIT(22) -> SLIT("$22"); ILIT(23) -> SLIT("$23"); - ILIT(24) -> SLIT("$24"); ILIT(25) -> SLIT("$25"); - ILIT(26) -> SLIT("$26"); ILIT(27) -> SLIT("$27"); - ILIT(28) -> SLIT("$28"); ILIT(29) -> SLIT("$29"); - ILIT(30) -> SLIT("$30"); ILIT(31) -> SLIT("$31"); - 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(38) -> SLIT("$f6"); ILIT(39) -> SLIT("$f7"); - 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(46) -> SLIT("$f14"); ILIT(47) -> SLIT("$f15"); - 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(54) -> SLIT("$f22"); ILIT(55) -> SLIT("$f23"); - 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(62) -> SLIT("$f30"); ILIT(63) -> SLIT("$f31"); - _ -> SLIT("very naughty alpha register") - }) - -pprCond :: Cond -> Unpretty -pprCond EQ = uppPStr SLIT("eq") -pprCond LT = uppPStr SLIT("lt") -pprCond LE = uppPStr SLIT("le") -pprCond ULT = uppPStr SLIT("ult") -pprCond ULE = uppPStr SLIT("ule") -pprCond NE = uppPStr SLIT("ne") -pprCond GT = uppPStr SLIT("gt") -pprCond GE = uppPStr SLIT("ge") - -pprImm :: PprStyle -> Imm -> Unpretty - -pprImm sty (ImmInt i) = uppInt i -pprImm sty (ImmInteger i) = uppInteger i - -pprImm sty (ImmCLbl l) = pprCLabel sty l - -pprImm sty (ImmLab s) = s - -pprAddr :: PprStyle -> Addr -> Unpretty -pprAddr sty (AddrReg reg) = uppBesides [uppLparen, pprReg reg, uppRparen] - -pprAddr sty (AddrImm imm) = pprImm sty imm - -pprAddr sty (AddrRegImm r1 imm) = - uppBesides [ - pprImm sty imm, - uppLparen, - pprReg r1, - uppRparen - ] - -pprRI :: PprStyle -> RI -> Unpretty -pprRI sty (RIReg r) = pprReg r -pprRI sty (RIImm r) = pprImm sty r - -pprRegRIReg :: PprStyle -> FAST_STRING -> Reg -> RI -> Reg -> Unpretty -pprRegRIReg sty name reg1 ri reg2 = - uppBesides [ - uppChar '\t', - uppPStr name, - uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty -pprSizeRegRegReg name size reg1 reg2 reg3 = - uppBesides [ - uppChar '\t', - uppPStr name, - pprSize size, - uppChar '\t', - pprReg reg1, - uppComma, - pprReg reg2, - uppComma, - pprReg reg3 - ] - -pprSize :: Size -> Unpretty -pprSize x = uppPStr - (case x of - B -> SLIT("b") - BU -> SLIT("bu") - W -> SLIT("w") - WU -> SLIT("wu") - L -> SLIT("l") - Q -> SLIT("q") - FF -> SLIT("f") - DF -> SLIT("d") - GF -> SLIT("g") - SF -> SLIT("s") - TF -> SLIT("t") - ) - -pprAlphaInstr :: PprStyle -> AlphaInstr -> Unpretty - -pprAlphaInstr sty (LD size reg addr) = - uppBesides [ - uppPStr SLIT("\tld"), - pprSize size, - uppChar '\t', - pprReg reg, - uppComma, - pprAddr sty addr - ] - -pprAlphaInstr sty (LDA reg addr) = - uppBesides [ - uppPStr SLIT("\tlda\t"), - pprReg reg, - uppComma, - pprAddr sty addr - ] - -pprAlphaInstr sty (LDAH reg addr) = - uppBesides [ - uppPStr SLIT("\tldah\t"), - pprReg reg, - uppComma, - pprAddr sty addr - ] - -pprAlphaInstr sty (LDGP reg addr) = - uppBesides [ - uppPStr SLIT("\tldgp\t"), - pprReg reg, - uppComma, - pprAddr sty addr - ] - -pprAlphaInstr sty (LDI size reg imm) = - uppBesides [ - uppPStr SLIT("\tldi"), - pprSize size, - uppChar '\t', - pprReg reg, - uppComma, - pprImm sty imm - ] - -pprAlphaInstr sty (ST size reg addr) = - uppBesides [ - uppPStr SLIT("\tst"), - pprSize size, - uppChar '\t', - pprReg reg, - uppComma, - pprAddr sty addr - ] - -pprAlphaInstr sty (CLR reg) = - uppBesides [ - uppPStr SLIT("\tclr\t"), - pprReg reg - ] - -pprAlphaInstr sty (ABS size ri reg) = - uppBesides [ - uppPStr SLIT("\tabs"), - pprSize size, - uppChar '\t', - pprRI sty ri, - uppComma, - pprReg reg - ] - -pprAlphaInstr sty (NEG size ov ri reg) = - uppBesides [ - uppPStr SLIT("\tneg"), - pprSize size, - if ov then uppPStr SLIT("v\t") else uppChar '\t', - pprRI sty ri, - uppComma, - pprReg reg - ] - -pprAlphaInstr sty (ADD size ov reg1 ri reg2) = - uppBesides [ - uppPStr SLIT("\tadd"), - pprSize size, - if ov then uppPStr SLIT("v\t") else uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (SADD size scale reg1 ri reg2) = - uppBesides [ - uppPStr (case scale of {L -> SLIT("\ts4"); Q -> SLIT("\ts8")}), - uppPStr SLIT("add"), - pprSize size, - uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (SUB size ov reg1 ri reg2) = - uppBesides [ - uppPStr SLIT("\tsub"), - pprSize size, - if ov then uppPStr SLIT("v\t") else uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (SSUB size scale reg1 ri reg2) = - uppBesides [ - uppPStr (case scale of {L -> SLIT("\ts4"); Q -> SLIT("\ts8")}), - uppPStr SLIT("sub"), - pprSize size, - uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (MUL size ov reg1 ri reg2) = - uppBesides [ - uppPStr SLIT("\tmul"), - pprSize size, - if ov then uppPStr SLIT("v\t") else uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (DIV size uns reg1 ri reg2) = - uppBesides [ - uppPStr SLIT("\tdiv"), - pprSize size, - if uns then uppPStr SLIT("u\t") else uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (REM size uns reg1 ri reg2) = - uppBesides [ - uppPStr SLIT("\trem"), - pprSize size, - if uns then uppPStr SLIT("u\t") else uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (NOT ri reg) = - uppBesides [ - uppPStr SLIT("\tnot"), - uppChar '\t', - pprRI sty ri, - uppComma, - pprReg reg - ] - -pprAlphaInstr sty (AND reg1 ri reg2) = pprRegRIReg sty SLIT("and") reg1 ri reg2 -pprAlphaInstr sty (ANDNOT reg1 ri reg2) = pprRegRIReg sty SLIT("andnot") reg1 ri reg2 -pprAlphaInstr sty (OR reg1 ri reg2) = pprRegRIReg sty SLIT("or") reg1 ri reg2 -pprAlphaInstr sty (ORNOT reg1 ri reg2) = pprRegRIReg sty SLIT("ornot") reg1 ri reg2 -pprAlphaInstr sty (XOR reg1 ri reg2) = pprRegRIReg sty SLIT("xor") reg1 ri reg2 -pprAlphaInstr sty (XORNOT reg1 ri reg2) = pprRegRIReg sty SLIT("xornot") reg1 ri reg2 - -pprAlphaInstr sty (SLL reg1 ri reg2) = pprRegRIReg sty SLIT("sll") reg1 ri reg2 -pprAlphaInstr sty (SRL reg1 ri reg2) = pprRegRIReg sty SLIT("srl") reg1 ri reg2 -pprAlphaInstr sty (SRA reg1 ri reg2) = pprRegRIReg sty SLIT("sra") reg1 ri reg2 - -pprAlphaInstr sty (ZAP reg1 ri reg2) = pprRegRIReg sty SLIT("zap") reg1 ri reg2 -pprAlphaInstr sty (ZAPNOT reg1 ri reg2) = pprRegRIReg sty SLIT("zapnot") reg1 ri reg2 - -pprAlphaInstr sty (NOP) = uppPStr SLIT("\tnop") - -pprAlphaInstr sty (CMP cond reg1 ri reg2) = - uppBesides [ - uppPStr SLIT("\tcmp"), - pprCond cond, - uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (FCLR reg) = - uppBesides [ - uppPStr SLIT("\tfclr\t"), - pprReg reg - ] - -pprAlphaInstr sty (FABS reg1 reg2) = - uppBesides [ - uppPStr SLIT("\tfabs\t"), - pprReg reg1, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (FNEG size reg1 reg2) = - uppBesides [ - uppPStr SLIT("\tneg"), - pprSize size, - uppChar '\t', - pprReg reg1, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3 -pprAlphaInstr sty (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3 -pprAlphaInstr sty (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3 -pprAlphaInstr sty (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3 - -pprAlphaInstr sty (CVTxy size1 size2 reg1 reg2) = - uppBesides [ - uppPStr SLIT("\tcvt"), - pprSize size1, - case size2 of {Q -> uppPStr SLIT("qc"); _ -> pprSize size2}, - uppChar '\t', - pprReg reg1, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (FCMP size cond reg1 reg2 reg3) = - uppBesides [ - uppPStr SLIT("\tcmp"), - pprSize size, - pprCond cond, - uppChar '\t', - pprReg reg1, - uppComma, - pprReg reg2, - uppComma, - pprReg reg3 - ] - -pprAlphaInstr sty (FMOV reg1 reg2) = - uppBesides [ - uppPStr SLIT("\tfmov\t"), - pprReg reg1, - uppComma, - pprReg reg2 - ] - -pprAlphaInstr sty (BI ALWAYS reg lab) = pprAlphaInstr sty (BR lab) - -pprAlphaInstr sty (BI NEVER reg lab) = uppNil - -pprAlphaInstr sty (BI cond reg lab) = - uppBesides [ - uppPStr SLIT("\tb"), - pprCond cond, - uppChar '\t', - pprReg reg, - uppComma, - pprImm sty lab - ] - -pprAlphaInstr sty (BF cond reg lab) = - uppBesides [ - uppPStr SLIT("\tfb"), - pprCond cond, - uppChar '\t', - pprReg reg, - uppComma, - pprImm sty lab - ] - -pprAlphaInstr sty (BR lab) = - uppBeside (uppPStr SLIT("\tbr\t")) (pprImm sty lab) - -pprAlphaInstr sty (JMP reg addr hint) = - uppBesides [ - uppPStr SLIT("\tjmp\t"), - pprReg reg, - uppComma, - pprAddr sty addr, - uppComma, - uppInt hint - ] - -pprAlphaInstr sty (BSR imm n) = - uppBeside (uppPStr SLIT("\tbsr\t")) (pprImm sty imm) - -pprAlphaInstr sty (JSR reg addr n) = - uppBesides [ - uppPStr SLIT("\tjsr\t"), - pprReg reg, - uppComma, - pprAddr sty addr - ] - -pprAlphaInstr sty (LABEL clab) = - uppBesides [ - if (externallyVisibleCLabel clab) then - uppBesides [uppPStr SLIT("\t.globl\t"), pprLab, uppChar '\n'] - else - uppNil, - pprLab, - uppChar ':' - ] - where pprLab = pprCLabel sty clab - -pprAlphaInstr sty (FUNBEGIN clab) = - uppBesides [ - if (externallyVisibleCLabel clab) then - uppBesides [uppPStr SLIT("\t.globl\t"), pprLab, uppChar '\n'] - else - uppNil, - uppPStr SLIT("\t.ent "), - pprLab, - uppChar '\n', - pprLab, - pp_ldgp, - pprLab, - pp_frame - ] - where - pprLab = pprCLabel sty clab -#ifdef USE_FAST_STRINGS - pp_ldgp = uppPStr (_packCString (A# ":\n\tldgp $29,0($27)\n"#)) - pp_frame = uppPStr (_packCString (A# "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#)) -#else - pp_ldgp = uppStr ":\n\tldgp $29,0($27)\n" - pp_frame = uppStr "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1" -#endif - -pprAlphaInstr sty (FUNEND clab) = - uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel sty clab) - -pprAlphaInstr sty (COMMENT s) = uppBeside (uppPStr SLIT("\t# ")) (uppPStr s) - -pprAlphaInstr sty (SEGMENT TextSegment) - = uppPStr SLIT("\t.text\n\t.align 3") - -pprAlphaInstr sty (SEGMENT DataSegment) - = uppPStr SLIT("\t.data\n\t.align 3") - -pprAlphaInstr sty (ASCII False str) = - uppBesides [ - uppStr "\t.asciz \"", - uppStr str, - uppChar '"' - ] - -pprAlphaInstr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60) - where - 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 [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\"")) - asciify (c:(cs@(d:_))) n | isDigit d = - uppBeside (uppStr (charToC c)) (asciify cs 0) - | otherwise = - uppBeside (uppStr (charToC c)) (asciify cs (n-1)) - -pprAlphaInstr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs) - where pp_item x = case s of - B -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x) - BU -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x) - W -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x) - WU -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x) - L -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x) - Q -> uppBeside (uppPStr SLIT("\t.quad\t")) (pprImm sty x) - FF -> uppBeside (uppPStr SLIT("\t.f_floating\t")) (pprImm sty x) - DF -> uppBeside (uppPStr SLIT("\t.d_floating\t")) (pprImm sty x) - GF -> uppBeside (uppPStr SLIT("\t.g_floating\t")) (pprImm sty x) - SF -> uppBeside (uppPStr SLIT("\t.s_floating\t")) (pprImm sty x) - TF -> uppBeside (uppPStr SLIT("\t.t_floating\t")) (pprImm sty x) - -\end{code} - -%************************************************************************ -%* * -\subsection[Schedule]{Register allocation information} -%* * -%************************************************************************ - -\begin{code} - -data AlphaRegs = SRegs BitSet BitSet - -instance MachineRegisters AlphaRegs where - mkMRegs xs = SRegs (mkBS ints) (mkBS floats') - where - (ints, floats) = partition (< 32) xs - floats' = map (subtract 32) 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 = - if n _LT_ ILIT(32) then SRegs (ints `minusBS` singletonBS IBOX(n)) floats - else SRegs ints (floats `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) - - useMRegs (SRegs ints floats) xs = - SRegs (ints `minusBS` ints') - (floats `minusBS` floats') - where - SRegs ints' floats' = mkMRegs xs - - freeMReg (SRegs ints floats) n = - if n _LT_ ILIT(32) then SRegs (ints `unionBS` singletonBS IBOX(n)) floats - else SRegs ints (floats `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) - - freeMRegs (SRegs ints floats) xs = - SRegs (ints `unionBS` ints') - (floats `unionBS` floats') - where - SRegs ints' floats' = mkMRegs xs - -instance MachineCode AlphaInstr where - regUsage = alphaRegUsage - regLiveness = alphaRegLiveness - patchRegs = alphaPatchRegs - - -- We spill just below the frame pointer, leaving two words per spill location. - spillReg dyn (MemoryReg i pk) = mkUnitList (ST (kindToSize pk) dyn (spRel i)) - loadReg (MemoryReg i pk) dyn = mkUnitList (LD (kindToSize pk) dyn (spRel i)) - -spRel :: Int -> Addr -spRel n = AddrRegImm sp (ImmInt (n * 8)) - -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} - -@alphaRegUsage@ returns the sets of src and destination registers used by -a particular instruction. Machine registers that are pre-allocated -to stgRegs are filtered out, because they are uninteresting from a -register allocation standpoint. (We wouldn't want them to end up on -the free list!) - -\begin{code} - -alphaRegUsage :: AlphaInstr -> RegUsage -alphaRegUsage instr = case instr of - LD B reg addr -> usage (regAddr addr, [reg, t9]) - LD BU reg addr -> usage (regAddr addr, [reg, t9]) - LD W reg addr -> usage (regAddr addr, [reg, t9]) - LD WU reg addr -> usage (regAddr addr, [reg, t9]) - LD sz reg addr -> usage (regAddr addr, [reg]) - LDA reg addr -> usage (regAddr addr, [reg]) - LDAH reg addr -> usage (regAddr addr, [reg]) - LDGP reg addr -> usage (regAddr addr, [reg]) - LDI sz reg imm -> usage ([], [reg]) - ST B reg addr -> usage (reg : regAddr addr, [t9, t10]) - ST W reg addr -> usage (reg : regAddr addr, [t9, t10]) - ST sz reg addr -> usage (reg : regAddr addr, []) - CLR reg -> usage ([], [reg]) - ABS sz ri reg -> usage (regRI ri, [reg]) - NEG sz ov ri reg -> usage (regRI ri, [reg]) - ADD sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SADD sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SSUB sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2]) - MUL sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) - DIV sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12]) - REM sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12]) - NOT ri reg -> usage (regRI ri, [reg]) - AND r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ZAP r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ZAPNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - CMP co r1 ar r2 -> usage (r1 : regRI ar, [r2]) - FCLR reg -> usage ([], [reg]) - FABS r1 r2 -> usage ([r1], [r2]) - FNEG sz r1 r2 -> usage ([r1], [r2]) - FADD sz r1 r2 r3 -> usage ([r1, r2], [r3]) - FDIV sz r1 r2 r3 -> usage ([r1, r2], [r3]) - FMUL sz r1 r2 r3 -> usage ([r1, r2], [r3]) - FSUB sz r1 r2 r3 -> usage ([r1, r2], [r3]) - CVTxy sz1 sz2 r1 r2 -> usage ([r1], [r2]) - FCMP sz co r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV r1 r2 -> usage ([r1], [r2]) - - - -- We assume that all local jumps will be BI/BF/BR. JMP must be out-of-line. - BI cond reg lbl -> usage ([reg], []) - BF cond reg lbl -> usage ([reg], []) - JMP reg addr hint -> RU (mkUniqSet (filter interesting (regAddr addr))) freeSet - - BSR _ n -> RU (argSet n) callClobberedSet - JSR reg addr n -> RU (argSet n) callClobberedSet - - _ -> noUsage - - where - usage (src, dst) = RU (mkUniqSet (filter interesting src)) - (mkUniqSet (filter interesting dst)) - - interesting (FixedReg _) = False - interesting _ = True - - regAddr (AddrReg r1) = [r1] - regAddr (AddrRegImm r1 _) = [r1] - regAddr (AddrImm _) = [] - - regRI (RIReg r) = [r] - regRI _ = [] - -freeRegs :: [Reg] -freeRegs = freeMappedRegs [0..63] - -freeMappedRegs :: [Int] -> [Reg] - -freeMappedRegs nums - = foldr free [] nums - where - free IBOX(i) acc - = if _IS_TRUE_(freeReg i) then (MappedReg i) : acc else acc - -freeSet :: UniqSet Reg -freeSet = mkUniqSet freeRegs - -noUsage :: RegUsage -noUsage = RU emptyUniqSet emptyUniqSet - --- Color me CAF-like -argSet :: Int -> UniqSet Reg -argSet 0 = emptyUniqSet -argSet 1 = mkUniqSet (freeMappedRegs [16, fReg 16]) -argSet 2 = mkUniqSet (freeMappedRegs [16, 17, fReg 16, fReg 17]) -argSet 3 = mkUniqSet (freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18]) -argSet 4 = mkUniqSet (freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19]) -argSet 5 = mkUniqSet (freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20]) -argSet 6 = mkUniqSet (freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21]) - -callClobberedSet :: UniqSet Reg -callClobberedSet = mkUniqSet callClobberedRegs - where - callClobberedRegs - = freeMappedRegs - [0, 1, 2, 3, 4, 5, 6, 7, 8, - 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, - fReg 0, fReg 1, fReg 10, fReg 11, fReg 12, fReg 13, fReg 14, fReg 15, - fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21, fReg 22, fReg 23, - fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30] - -\end{code} - -@alphaRegLiveness@ takes future liveness information and modifies it according to -the semantics of branches and labels. (An out-of-line branch clobbers the liveness -passed back by the following instruction; a forward local branch passes back the -liveness from the target label; a conditional branch merges the liveness from the -target and the liveness from its successor; a label stashes away the current liveness -in the future liveness environment). - -\begin{code} -alphaRegLiveness :: AlphaInstr -> RegLiveness -> RegLiveness -alphaRegLiveness instr info@(RL live future@(FL all env)) = case instr of - - -- We assume that all local jumps will be BI/BF. JMP must be out-of-line. - - BR (ImmCLbl lbl) -> RL (lookup lbl) future - BI _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionUniqSets` live) future - BF _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionUniqSets` live) future - JMP _ _ _ -> RL emptyUniqSet future - BSR _ _ -> RL live future - JSR _ _ _ -> RL live future - LABEL lbl -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live)) - _ -> info - - where - lookup lbl = case lookupFM env lbl of - Just regs -> regs - Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++ - " in future?") emptyUniqSet - -\end{code} - -@alphaPatchRegs@ takes an instruction (possibly with -MemoryReg/UnmappedReg registers) and changes all register references -according to the supplied environment. - -\begin{code} - -alphaPatchRegs :: AlphaInstr -> (Reg -> Reg) -> AlphaInstr -alphaPatchRegs instr env = case instr of - LD sz reg addr -> LD sz (env reg) (fixAddr addr) - LDA reg addr -> LDA (env reg) (fixAddr addr) - LDAH reg addr -> LDAH (env reg) (fixAddr addr) - LDGP reg addr -> LDGP (env reg) (fixAddr addr) - LDI sz reg imm -> LDI sz (env reg) imm - ST sz reg addr -> ST sz (env reg) (fixAddr addr) - CLR reg -> CLR (env reg) - ABS sz ar reg -> ABS sz (fixRI ar) (env reg) - NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg) - ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2) - SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2) - SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2) - SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2) - MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2) - DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2) - REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2) - NOT ar reg -> NOT (fixRI ar) (env reg) - AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2) - ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2) - OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2) - ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2) - XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2) - XORNOT r1 ar r2 -> XORNOT (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2) - ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2) - CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2) - FCLR reg -> FCLR (env reg) - FABS r1 r2 -> FABS (env r1) (env r2) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2) - FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3) - FMOV r1 r2 -> FMOV (env r1) (env r2) - BI cond reg lbl -> BI cond (env reg) lbl - BF cond reg lbl -> BF cond (env reg) lbl - JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint - JSR reg addr i -> JSR (env reg) (fixAddr addr) i - _ -> instr - - where - fixAddr (AddrReg r1) = AddrReg (env r1) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - fixAddr other = other - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other - -\end{code} - -If you value your sanity, do not venture below this line. - -\begin{code} - --- platform.h is generate and tells us what the target architecture is -#include "../../includes/platform.h" -#include "../../includes/MachRegs.h" -#include "../../includes/alpha-dec-osf1.h" - --- Redefine the literals used for Alpha floating point register names --- in the header files. Gag me with a spoon, eh? - -#define f0 32 -#define f1 33 -#define f2 34 -#define f3 35 -#define f4 36 -#define f5 37 -#define f6 38 -#define f7 39 -#define f8 40 -#define f9 41 -#define f10 42 -#define f11 43 -#define f12 44 -#define f13 45 -#define f14 46 -#define f15 47 -#define f16 48 -#define f17 49 -#define f18 50 -#define f19 51 -#define f20 52 -#define f21 53 -#define f22 54 -#define f23 55 -#define f24 56 -#define f25 57 -#define f26 58 -#define f27 59 -#define f28 60 -#define f29 61 -#define f30 62 -#define f31 63 - -baseRegOffset :: MagicId -> Int -baseRegOffset StkOReg = OFFSET_StkO -baseRegOffset (VanillaReg _ ILIT(1)) = OFFSET_R1 -baseRegOffset (VanillaReg _ ILIT(2)) = OFFSET_R2 -baseRegOffset (VanillaReg _ ILIT(3)) = OFFSET_R3 -baseRegOffset (VanillaReg _ ILIT(4)) = OFFSET_R4 -baseRegOffset (VanillaReg _ ILIT(5)) = OFFSET_R5 -baseRegOffset (VanillaReg _ ILIT(6)) = OFFSET_R6 -baseRegOffset (VanillaReg _ ILIT(7)) = OFFSET_R7 -baseRegOffset (VanillaReg _ ILIT(8)) = OFFSET_R8 -baseRegOffset (FloatReg ILIT(1)) = OFFSET_Flt1 -baseRegOffset (FloatReg ILIT(2)) = OFFSET_Flt2 -baseRegOffset (FloatReg ILIT(3)) = OFFSET_Flt3 -baseRegOffset (FloatReg ILIT(4)) = OFFSET_Flt4 -baseRegOffset (DoubleReg ILIT(1)) = OFFSET_Dbl1 -baseRegOffset (DoubleReg ILIT(2)) = OFFSET_Dbl2 -baseRegOffset TagReg = OFFSET_Tag -baseRegOffset RetReg = OFFSET_Ret -baseRegOffset SpA = OFFSET_SpA -baseRegOffset SuA = OFFSET_SuA -baseRegOffset SpB = OFFSET_SpB -baseRegOffset SuB = OFFSET_SuB -baseRegOffset Hp = OFFSET_Hp -baseRegOffset HpLim = OFFSET_HpLim -baseRegOffset LivenessReg = OFFSET_Liveness ---baseRegOffset ActivityReg = OFFSET_Activity -#ifdef DEBUG -baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" -baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg" -baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg" -baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre" -baseRegOffset VoidReg = panic "baseRegOffset:VoidReg" -#endif - -callerSaves :: MagicId -> Bool -#ifdef CALLER_SAVES_Base -callerSaves BaseReg = True -#endif -#ifdef CALLER_SAVES_StkO -callerSaves StkOReg = True -#endif -#ifdef CALLER_SAVES_R1 -callerSaves (VanillaReg _ ILIT(1)) = True -#endif -#ifdef CALLER_SAVES_R2 -callerSaves (VanillaReg _ ILIT(2)) = True -#endif -#ifdef CALLER_SAVES_R3 -callerSaves (VanillaReg _ ILIT(3)) = True -#endif -#ifdef CALLER_SAVES_R4 -callerSaves (VanillaReg _ ILIT(4)) = True -#endif -#ifdef CALLER_SAVES_R5 -callerSaves (VanillaReg _ ILIT(5)) = True -#endif -#ifdef CALLER_SAVES_R6 -callerSaves (VanillaReg _ ILIT(6)) = True -#endif -#ifdef CALLER_SAVES_R7 -callerSaves (VanillaReg _ ILIT(7)) = True -#endif -#ifdef CALLER_SAVES_R8 -callerSaves (VanillaReg _ ILIT(8)) = True -#endif -#ifdef CALLER_SAVES_FltReg1 -callerSaves (FloatReg ILIT(1)) = True -#endif -#ifdef CALLER_SAVES_FltReg2 -callerSaves (FloatReg ILIT(2)) = True -#endif -#ifdef CALLER_SAVES_FltReg3 -callerSaves (FloatReg ILIT(3)) = True -#endif -#ifdef CALLER_SAVES_FltReg4 -callerSaves (FloatReg ILIT(4)) = True -#endif -#ifdef CALLER_SAVES_DblReg1 -callerSaves (DoubleReg ILIT(1)) = True -#endif -#ifdef CALLER_SAVES_DblReg2 -callerSaves (DoubleReg ILIT(2)) = True -#endif -#ifdef CALLER_SAVES_Tag -callerSaves TagReg = True -#endif -#ifdef CALLER_SAVES_Ret -callerSaves RetReg = True -#endif -#ifdef CALLER_SAVES_SpA -callerSaves SpA = True -#endif -#ifdef CALLER_SAVES_SuA -callerSaves SuA = True -#endif -#ifdef CALLER_SAVES_SpB -callerSaves SpB = True -#endif -#ifdef CALLER_SAVES_SuB -callerSaves SuB = True -#endif -#ifdef CALLER_SAVES_Hp -callerSaves Hp = True -#endif -#ifdef CALLER_SAVES_HpLim -callerSaves HpLim = True -#endif -#ifdef CALLER_SAVES_Liveness -callerSaves LivenessReg = True -#endif -#ifdef CALLER_SAVES_Activity ---callerSaves ActivityReg = True -#endif -#ifdef CALLER_SAVES_StdUpdRetVec -callerSaves StdUpdRetVecReg = True -#endif -#ifdef CALLER_SAVES_StkStub -callerSaves StkStubReg = True -#endif -callerSaves _ = False - -stgRegMap :: MagicId -> Maybe Reg -#ifdef REG_Base -stgRegMap BaseReg = Just (FixedReg ILIT(REG_Base)) -#endif -#ifdef REG_StkO -stgRegMap StkOReg = Just (FixedReg ILIT(REG_StkOReg)) -#endif -#ifdef REG_R1 -stgRegMap (VanillaReg _ ILIT(1)) = Just (FixedReg ILIT(REG_R1)) -#endif -#ifdef REG_R2 -stgRegMap (VanillaReg _ ILIT(2)) = Just (FixedReg ILIT(REG_R2)) -#endif -#ifdef REG_R3 -stgRegMap (VanillaReg _ ILIT(3)) = Just (FixedReg ILIT(REG_R3)) -#endif -#ifdef REG_R4 -stgRegMap (VanillaReg _ ILIT(4)) = Just (FixedReg ILIT(REG_R4)) -#endif -#ifdef REG_R5 -stgRegMap (VanillaReg _ ILIT(5)) = Just (FixedReg ILIT(REG_R5)) -#endif -#ifdef REG_R6 -stgRegMap (VanillaReg _ ILIT(6)) = Just (FixedReg ILIT(REG_R6)) -#endif -#ifdef REG_R7 -stgRegMap (VanillaReg _ ILIT(7)) = Just (FixedReg ILIT(REG_R7)) -#endif -#ifdef REG_R8 -stgRegMap (VanillaReg _ ILIT(8)) = Just (FixedReg ILIT(REG_R8)) -#endif -#ifdef REG_Flt1 -stgRegMap (FloatReg ILIT(1)) = Just (FixedReg ILIT(REG_Flt1)) -#endif -#ifdef REG_Flt2 -stgRegMap (FloatReg ILIT(2)) = Just (FixedReg ILIT(REG_Flt2)) -#endif -#ifdef REG_Flt3 -stgRegMap (FloatReg ILIT(3)) = Just (FixedReg ILIT(REG_Flt3)) -#endif -#ifdef REG_Flt4 -stgRegMap (FloatReg ILIT(4)) = Just (FixedReg ILIT(REG_Flt4)) -#endif -#ifdef REG_Dbl1 -stgRegMap (DoubleReg ILIT(1)) = Just (FixedReg ILIT(REG_Dbl1)) -#endif -#ifdef REG_Dbl2 -stgRegMap (DoubleReg ILIT(2)) = Just (FixedReg ILIT(REG_Dbl2)) -#endif -#ifdef REG_Tag -stgRegMap TagReg = Just (FixedReg ILIT(REG_TagReg)) -#endif -#ifdef REG_Ret -stgRegMap RetReg = Just (FixedReg ILIT(REG_Ret)) -#endif -#ifdef REG_SpA -stgRegMap SpA = Just (FixedReg ILIT(REG_SpA)) -#endif -#ifdef REG_SuA -stgRegMap SuA = Just (FixedReg ILIT(REG_SuA)) -#endif -#ifdef REG_SpB -stgRegMap SpB = Just (FixedReg ILIT(REG_SpB)) -#endif -#ifdef REG_SuB -stgRegMap SuB = Just (FixedReg ILIT(REG_SuB)) -#endif -#ifdef REG_Hp -stgRegMap Hp = Just (FixedReg ILIT(REG_Hp)) -#endif -#ifdef REG_HpLim -stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim)) -#endif -#ifdef REG_Liveness -stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness)) -#endif -#ifdef REG_Activity ---stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity)) -#endif -#ifdef REG_StdUpdRetVec -stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec)) -#endif -#ifdef REG_StkStub -stgRegMap StkStubReg = Just (FixedReg ILIT(REG_StkStub)) -#endif -stgRegMap _ = Nothing - -\end{code} - -Here is the list of registers we can use in register allocation. - -With a per-instruction clobber list, we might be able to get some of -these back, but it's probably not worth the hassle. - -\begin{code} - -freeReg :: FAST_INT -> FAST_BOOL - -freeReg ILIT(26) = _FALSE_ -- return address (ra) -freeReg ILIT(28) = _FALSE_ -- reserved for the assembler (at) -freeReg ILIT(29) = _FALSE_ -- global pointer (gp) -freeReg ILIT(30) = _FALSE_ -- stack pointer (sp) -freeReg ILIT(31) = _FALSE_ -- always zero (zero) -freeReg ILIT(63) = _FALSE_ -- always zero (f31) - -#ifdef REG_Base -freeReg ILIT(REG_Base) = _FALSE_ -#endif -#ifdef REG_StkO -freeReg ILIT(REG_StkO) = _FALSE_ -#endif -#ifdef REG_R1 -freeReg ILIT(REG_R1) = _FALSE_ -#endif -#ifdef REG_R2 -freeReg ILIT(REG_R2) = _FALSE_ -#endif -#ifdef REG_R3 -freeReg ILIT(REG_R3) = _FALSE_ -#endif -#ifdef REG_R4 -freeReg ILIT(REG_R4) = _FALSE_ -#endif -#ifdef REG_R5 -freeReg ILIT(REG_R5) = _FALSE_ -#endif -#ifdef REG_R6 -freeReg ILIT(REG_R6) = _FALSE_ -#endif -#ifdef REG_R7 -freeReg ILIT(REG_R7) = _FALSE_ -#endif -#ifdef REG_R8 -freeReg ILIT(REG_R8) = _FALSE_ -#endif -#ifdef REG_Flt1 -freeReg ILIT(REG_Flt1) = _FALSE_ -#endif -#ifdef REG_Flt2 -freeReg ILIT(REG_Flt2) = _FALSE_ -#endif -#ifdef REG_Flt3 -freeReg ILIT(REG_Flt3) = _FALSE_ -#endif -#ifdef REG_Flt4 -freeReg ILIT(REG_Flt4) = _FALSE_ -#endif -#ifdef REG_Dbl1 -freeReg ILIT(REG_Dbl1) = _FALSE_ -#endif -#ifdef REG_Dbl2 -freeReg ILIT(REG_Dbl2) = _FALSE_ -#endif -#ifdef REG_Tag -freeReg ILIT(REG_Tag) = _FALSE_ -#endif -#ifdef REG_Ret -freeReg ILIT(REG_Ret) = _FALSE_ -#endif -#ifdef REG_SpA -freeReg ILIT(REG_SpA) = _FALSE_ -#endif -#ifdef REG_SuA -freeReg ILIT(REG_SuA) = _FALSE_ -#endif -#ifdef REG_SpB -freeReg ILIT(REG_SpB) = _FALSE_ -#endif -#ifdef REG_SuB -freeReg ILIT(REG_SuB) = _FALSE_ -#endif -#ifdef REG_Hp -freeReg ILIT(REG_Hp) = _FALSE_ -#endif -#ifdef REG_HpLim -freeReg ILIT(REG_HpLim) = _FALSE_ -#endif -#ifdef REG_Liveness -freeReg ILIT(REG_Liveness) = _FALSE_ -#endif -#ifdef REG_Activity ---freeReg ILIT(REG_Activity) = _FALSE_ -#endif -#ifdef REG_StdUpdRetVec -freeReg ILIT(REG_StdUpdRetVec) = _FALSE_ -#endif -#ifdef REG_StkStub -freeReg ILIT(REG_StkStub) = _FALSE_ -#endif -freeReg _ = _TRUE_ - -reservedRegs :: [Int] -reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2, NCG_Reserved_F1, NCG_Reserved_F2] - -\end{code} diff --git a/ghc/compiler/nativeGen/AlphaDesc.lhs b/ghc/compiler/nativeGen/AlphaDesc.lhs deleted file mode 100644 index 43852f2..0000000 --- a/ghc/compiler/nativeGen/AlphaDesc.lhs +++ /dev/null @@ -1,208 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1995 -% -\section[AlphaDesc]{The Alpha Machine Description} - -\begin{code} -#include "HsVersions.h" - -module AlphaDesc ( - mkAlpha - - -- and assorted nonsense referenced by the class methods - ) where - -import AbsCSyn -import PrelInfo ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..), - RegUsage(..), RegLiveness(..), FutureLive(..) - ) -import CLabel ( CLabel ) -import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, - switchIsOn, SwitchResult(..) - ) -import HeapOffs ( hpRelToInt ) -import MachDesc -import Maybes ( Maybe(..) ) -import OrdList -import Outputable -import PrimRep ( PrimRep(..) ) -import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) -import AlphaCode -import AlphaGen ( alphaCodeGen ) -import Stix -import StixMacro -import StixPrim -import UniqSupply -import Util - -\end{code} - -Header sizes depend only on command-line options, not on the target -architecture. (I think.) - -\begin{code} - -fhs :: (GlobalSwitch -> SwitchResult) -> Int - -fhs switches = 1 + profFHS + ageFHS - where - profFHS = if switchIsOn switches SccProfilingOn then 1 else 0 - ageFHS = if switchIsOn switches SccProfilingOn then 1 else 0 - -vhs :: (GlobalSwitch -> SwitchResult) -> SMRep -> Int - -vhs switches sm = case sm of - StaticRep _ _ -> 0 - SpecialisedRep _ _ _ _ -> 0 - GenericRep _ _ _ -> 0 - BigTupleRep _ -> 1 - MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -} - DataRep _ -> 1 - DynamicRep -> 2 - BlackHoleRep -> 0 - PhantomRep -> panic "vhs:phantom" - -\end{code} - -Here we map STG registers onto appropriate Stix Trees. First, we -handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@. -The rest are either in real machine registers or stored as offsets -from BaseReg. - -\begin{code} - -alphaReg :: (GlobalSwitch -> SwitchResult) -> MagicId -> RegLoc - -alphaReg switches x = - case stgRegMap x of - Just reg -> Save nonReg - Nothing -> Always nonReg - where nonReg = case x of - StkStubReg -> sStLitLbl SLIT("STK_STUB_closure") - StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame") - BaseReg -> sStLitLbl SLIT("MainRegTable") - 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) - _ -> StInd (kindFromMagicId x) - (StPrim IntAddOp [baseLoc, StInt (toInteger (offset*8))]) - baseLoc = case stgRegMap BaseReg of - Just _ -> StReg (StixMagicId BaseReg) - Nothing -> sStLitLbl SLIT("MainRegTable") - offset = baseRegOffset x - -\end{code} - -Sizes in bytes. - -\begin{code} - -size pk = case kindToSize pk of - {B -> 1; BU -> 1; W -> 2; WU -> 2; L -> 4; FF -> 4; SF -> 4; _ -> 8} - -\end{code} - -Now the volatile saves and restores. We add the basic guys to the list of ``user'' -registers provided. Note that there are more basic registers on the restore list, -because some are reloaded from constants. - -\begin{code} - -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 - 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) - ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,{-ActivityReg,-}StkStubReg,StdUpdRetVecReg] ++ vols)) - where - restore x = StAssign (kindFromMagicId x) reg loc - where reg = StReg (StixMagicId x) - loc = case alphaReg switches x of - Save loc -> loc - Always loc -> panic "vrests" - -\end{code} - -Static closure sizes. - -\begin{code} - -charLikeSize, intLikeSize :: Target -> Int - -charLikeSize target = - size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1) - where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm - -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 - words = fhs switches + vhs switches (MuTupleRep 0) - -dhs switches = StInt (toInteger words) - where - words = fhs switches + vhs switches (DataRep 0) - -\end{code} - -Setting up a alpha target. - -\begin{code} - -mkAlpha :: (GlobalSwitch -> SwitchResult) - -> (Target, - (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen - Bool, -- underscore - (String -> String)) -- fmtAsmLbl - -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 - csz = charLikeSize target - isz = intLikeSize target - mhs' = mhs switches - dhs' = dhs switches - ps = genPrimCode target - mc = genMacroCode target - hc = doHeapCheck - target = mkTarget {-switches-} fhs' vhs' alphaReg' {-id-} size - hprel as as' - (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc) - {-alphaCodeGen False mungeLabel-} - in - (target, alphaCodeGen, False, mungeLabel) -\end{code} - -The alpha assembler likes temporary labels to look like \tr{$L123} -instead of \tr{L123}. (Don't toss the \tr{L}, because then \tr{Lf28} -turns into \tr{$f28}.) -\begin{code} -mungeLabel :: String -> String -mungeLabel xs = '$' : xs -\end{code} diff --git a/ghc/compiler/nativeGen/AlphaGen.lhs b/ghc/compiler/nativeGen/AlphaGen.lhs deleted file mode 100644 index 2d5071a..0000000 --- a/ghc/compiler/nativeGen/AlphaGen.lhs +++ /dev/null @@ -1,1107 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1995 -% - -\begin{code} -#include "HsVersions.h" - -module AlphaGen ( - alphaCodeGen, - - -- and, for self-sufficiency - PprStyle, StixTree, CSeq - ) where - -IMPORT_Trace - -import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId ) -import PrelInfo ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AsmRegAlloc ( runRegAllocate, extractMappedRegNos, mkReg, - Reg(..), RegLiveness(..), RegUsage(..), FutureLive(..), - MachineRegisters(..), MachineCode(..) - ) -import CLabel ( CLabel, isAsmTemp ) -import AlphaCode {- everything -} -import MachDesc -import Maybes ( maybeToBool, Maybe(..) ) -import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList ) -import Outputable -import AlphaDesc -import Stix -import UniqSupply -import Pretty -import Unpretty -import Util - -type CodeBlock a = (OrdList a -> OrdList a) - -\end{code} - -%************************************************************************ -%* * -\subsection[AlphaCodeGen]{Generating Alpha Code} -%* * -%************************************************************************ - -This is the top-level code-generation function for the Alpha. - -\begin{code} - -alphaCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty -alphaCodeGen sty trees = - mapUs genAlphaCode trees `thenUs` \ dynamicCodes -> - let - staticCodes = scheduleAlphaCode dynamicCodes - pretty = printLabeledCodes sty staticCodes - in - returnUs pretty - -\end{code} - -This bit does the code scheduling. The scheduler must also deal with -register allocation of temporaries. Much parallelism can be exposed via -the OrdList, but more might occur, so further analysis might be needed. - -\begin{code} - -scheduleAlphaCode :: [AlphaCode] -> [AlphaInstr] -scheduleAlphaCode = concat . map (runRegAllocate freeAlphaRegs reservedRegs) - where - freeAlphaRegs :: AlphaRegs - freeAlphaRegs = mkMRegs (extractMappedRegNos freeRegs) - -\end{code} - -Registers passed up the tree. If the stix code forces the register -to live in a pre-decided machine register, it comes out as @Fixed@; -otherwise, it comes out as @Any@, and the parent can decide which -register to put it in. - -\begin{code} - -data Register - = Fixed Reg PrimRep (CodeBlock AlphaInstr) - | Any PrimRep (Reg -> (CodeBlock AlphaInstr)) - -registerCode :: Register -> Reg -> CodeBlock AlphaInstr -registerCode (Fixed _ _ code) reg = code -registerCode (Any _ code) reg = code reg - -registerName :: Register -> Reg -> Reg -registerName (Fixed reg _ _) _ = reg -registerName (Any _ _) reg = reg - -registerKind :: Register -> PrimRep -registerKind (Fixed _ pk _) = pk -registerKind (Any pk _) = pk - -isFixed :: Register -> Bool -isFixed (Fixed _ _ _) = True -isFixed (Any _ _) = False - -\end{code} - -Memory addressing modes passed up the tree. - -\begin{code} - -data Amode = Amode Addr (CodeBlock AlphaInstr) - -amodeAddr (Amode addr _) = addr -amodeCode (Amode _ code) = code - -\end{code} - -General things for putting together code sequences. - -\begin{code} - -asmVoid :: OrdList AlphaInstr -asmVoid = mkEmptyList - -asmInstr :: AlphaInstr -> AlphaCode -asmInstr i = mkUnitList i - -asmSeq :: [AlphaInstr] -> AlphaCode -asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is - -asmParThen :: [AlphaCode] -> CodeBlock AlphaInstr -asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code - -returnInstr :: AlphaInstr -> UniqSM (CodeBlock AlphaInstr) -returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs) - -returnInstrs :: [AlphaInstr] -> UniqSM (CodeBlock AlphaInstr) -returnInstrs instrs = returnUs (\xs -> 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 - -mkSeqInstrs :: [AlphaInstr] -> (CodeBlock AlphaInstr) -mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code - -\end{code} - -Top level alpha code generator for a chunk of stix code. - -\begin{code} - -genAlphaCode :: [StixTree] -> UniqSM (AlphaCode) - -genAlphaCode trees = - mapUs getCode trees `thenUs` \ blocks -> - returnUs (foldr (.) id blocks asmVoid) - -\end{code} - -Code extractor for an entire stix tree---stix statement level. - -\begin{code} - -getCode - :: StixTree -- a stix statement - -> UniqSM (CodeBlock AlphaInstr) - -getCode (StSegment seg) = returnInstr (SEGMENT seg) - -getCode (StAssign pk dst src) - | isFloatingRep pk = assignFltCode pk dst src - | otherwise = assignIntCode pk dst src - -getCode (StLabel lab) = returnInstr (LABEL lab) - -getCode (StFunBegin lab) = returnInstr (FUNBEGIN lab) - -getCode (StFunEnd lab) = returnInstr (FUNEND lab) - -getCode (StJump arg) = genJump arg - --- When falling through on the alpha, we still have to load pv with the --- address of the next routine, so that it can load gp -getCode (StFallThrough lbl) = returnInstr (LDA pv (AddrImm (ImmCLbl lbl))) - -getCode (StCondJump lbl arg) = genCondJump lbl arg - -getCode (StData kind args) = - mapAndUnzipUs getData args `thenUs` \ (codes, imms) -> - returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms)) - (foldr1 (.) codes xs)) - where - 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) - -\end{code} - -Generate code to get a subtree into a register. - -\begin{code} - -getReg :: StixTree -> UniqSM Register - -getReg (StReg (StixMagicId stgreg)) = - case stgRegMap stgreg of - Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id) - -- cannae be Nothing - -getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id) - -getReg (StDouble d) = - getUniqLabelNCG `thenUs` \ lbl -> - getNewRegNCG PtrRep `thenUs` \ tmp -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - DATA TF [ImmLab (prettyToUn (ppRational d))], - SEGMENT TextSegment, - LDA tmp (AddrImm (ImmCLbl lbl)), - LD TF dst (AddrReg tmp)] - in - returnUs (Any DoubleRep code) - -getReg (StString s) = - getUniqLabelNCG `thenUs` \ lbl -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - ASCII True (_UNPK_ s), - SEGMENT TextSegment, - LDA dst (AddrImm (ImmCLbl lbl))] - in - returnUs (Any PtrRep code) - -getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' = - getUniqLabelNCG `thenUs` \ lbl -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - ASCII False (init xs), - SEGMENT TextSegment, - LDA dst (AddrImm (ImmCLbl lbl))] - in - returnUs (Any PtrRep code) - where - xs = _UNPK_ (_TAIL_ s) - -getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree) - -getReg (StCall fn kind args) = - genCCall fn kind args `thenUs` \ call -> - returnUs (Fixed reg kind call) - where - reg = if isFloatingRep kind then f0 else v0 - -getReg (StPrim primop args) = - case primop of - - CharGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x] - CharGeOp -> case args of [x,y] -> trivialCode (CMP LE) [y,x] - CharEqOp -> trivialCode (CMP EQ) args - CharNeOp -> intNECode args - CharLtOp -> trivialCode (CMP LT) args - CharLeOp -> trivialCode (CMP LE) args - - IntAddOp -> trivialCode (ADD Q False) args - - IntSubOp -> trivialCode (SUB Q False) args - IntMulOp -> trivialCode (MUL Q False) args - IntQuotOp -> trivialCode (DIV Q False) args - 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 - SllOp -> trivialCode SLL args - SraOp -> trivialCode SRA args - SrlOp -> trivialCode SRL 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 - IntNeOp -> intNECode args - IntLtOp -> trivialCode (CMP LT) args - IntLeOp -> trivialCode (CMP LE) args - - WordGtOp -> case args of [x,y] -> trivialCode (CMP ULT) [y,x] - WordGeOp -> case args of [x,y] -> trivialCode (CMP ULE) [y,x] - WordEqOp -> trivialCode (CMP EQ) args - WordNeOp -> intNECode args - WordLtOp -> trivialCode (CMP ULT) args - WordLeOp -> trivialCode (CMP ULE) args - - AddrGtOp -> case args of [x,y] -> trivialCode (CMP ULT) [y,x] - AddrGeOp -> case args of [x,y] -> trivialCode (CMP ULE) [y,x] - AddrEqOp -> trivialCode (CMP EQ) args - AddrNeOp -> intNECode args - AddrLtOp -> trivialCode (CMP ULT) args - AddrLeOp -> trivialCode (CMP ULE) args - - FloatAddOp -> trivialFCode (FADD TF) args - FloatSubOp -> trivialFCode (FSUB TF) args - FloatMulOp -> trivialFCode (FMUL TF) args - FloatDivOp -> trivialFCode (FDIV TF) args - FloatNegOp -> trivialUFCode (FNEG TF) args - - FloatGtOp -> cmpFCode (FCMP TF LE) EQ args - FloatGeOp -> cmpFCode (FCMP TF LT) EQ args - FloatEqOp -> cmpFCode (FCMP TF EQ) NE args - FloatNeOp -> cmpFCode (FCMP TF EQ) EQ args - FloatLtOp -> cmpFCode (FCMP TF LT) NE args - FloatLeOp -> cmpFCode (FCMP TF LE) NE args - - 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 - DoubleNeOp -> cmpFCode (FCMP TF EQ) EQ args - DoubleLtOp -> cmpFCode (FCMP TF LT) NE args - DoubleLeOp -> cmpFCode (FCMP TF LE) NE 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 - - where - call fn pk = getReg (StCall fn pk args) - -getReg (StInd pk mem) = - getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - size = kindToSize pk - code__2 dst = code . mkSeqInstr (LD size dst src) - in - returnUs (Any pk code__2) - -getReg (StInt i) - | is8Bits i = - let - code dst = mkSeqInstr (OR zero (RIImm src) dst) - in - returnUs (Any IntRep code) - | otherwise = - let - code dst = mkSeqInstr (LDI Q dst src) - in - returnUs (Any IntRep code) - where - src = ImmInt (fromInteger i) - -getReg leaf - | maybeToBool imm = - let - code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) - in - returnUs (Any PtrRep code) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - -\end{code} - -Now, given a tree (the argument to an StInd) that references memory, -produce a suitable addressing mode. - -\begin{code} - -getAmode :: StixTree -> UniqSM Amode - -getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) - -getAmode (StPrim IntSubOp [x, StInt i]) = - getNewRegNCG PtrRep `thenUs` \ tmp -> - getReg x `thenUs` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (-(fromInteger i)) - in - returnUs (Amode (AddrRegImm reg off) code) - - -getAmode (StPrim IntAddOp [x, StInt i]) = - getNewRegNCG PtrRep `thenUs` \ tmp -> - getReg x `thenUs` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (fromInteger i) - in - returnUs (Amode (AddrRegImm reg off) code) - -getAmode leaf - | maybeToBool imm = - returnUs (Amode (AddrImm imm__2) id) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - -getAmode other = - getNewRegNCG PtrRep `thenUs` \ tmp -> - getReg other `thenUs` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - in - returnUs (Amode (AddrReg reg) code) - -\end{code} - -Try to get a value into a specific register (or registers) for a call. -The first 6 arguments go into the appropriate argument register -(separate registers for integer and floating point arguments, but used -in lock-step), and the remaining arguments are dumped to the stack, -beginning at 0(sp). Our first argument is a pair of the list of -remaining argument registers to be assigned for this call and the next -stack offset to use for overflowing arguments. This way, @getCallArg@ -can be applied to all of a call's arguments using @mapAccumL@. - -\begin{code} - -getCallArg - :: ([(Reg,Reg)],Int) -- Argument registers and stack offset (accumulator) - -> StixTree -- Current argument - -> 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 `thenUs` \ register -> - let - reg = if isFloatingRep pk then fDst else iDst - code = registerCode register reg - src = registerName register reg - pk = registerKind register - in - 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 - 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 `thenUs` \ register -> - getNewRegNCG (registerKind register) - `thenUs` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - pk = registerKind register - sz = kindToSize pk - in - returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) - -\end{code} - -Assignments are really at the heart of the whole code generation business. -Almost all top-level nodes of any real importance are assignments, which -correspond to loads, stores, or register transfers. If we're really lucky, -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). - -\begin{code} - -assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr) - -assignIntCode pk (StInd _ dst) src = - 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 - src__2 = registerName register tmp - sz = kindToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) - in - returnUs code__2 - -assignIntCode pk dst src = - 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 . mkSeqInstr (OR src__2 (RIReg src__2) dst__2) - else code - in - returnUs code__2 - -assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr) - -assignFltCode pk (StInd _ dst) src = - 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 - src__2 = registerName register tmp - sz = kindToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) - in - returnUs code__2 - -assignFltCode pk dst src = - 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 . mkSeqInstr (FMOV src__2 dst__2) - else code - in - returnUs code__2 - -\end{code} - -Generating an unconditional branch. We accept two types of targets: -an immediate CLabel or a tree that gets evaluated into a register. -Any CLabels which are AsmTemporaries are assumed to be in the local -block of code, close enough for a branch instruction. Other CLabels -are assumed to be far away, so we use jmp. - -\begin{code} - -genJump - :: StixTree -- the branch target - -> UniqSM (CodeBlock AlphaInstr) - -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 `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> - let - dst = registerName register pv - code = registerCode register pv - target = registerName register pv - in - if isFixed register then - returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0] - else - 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. - -\begin{code} - -genCondJump - :: CLabel -- the branch target - -> StixTree -- the condition on which to branch - -> UniqSM (CodeBlock AlphaInstr) - -genCondJump lbl (StPrim op [x, StInt 0]) = - getReg x `thenUs` \ register -> - getNewRegNCG (registerKind register) - `thenUs` \ tmp -> - let - code = registerCode register tmp - value = registerName register tmp - pk = registerKind register - target = ImmCLbl lbl - in - returnSeq code [BI (cmpOp op) value target] - where - cmpOp CharGtOp = GT - cmpOp CharGeOp = GE - cmpOp CharEqOp = EQ - cmpOp CharNeOp = NE - cmpOp CharLtOp = LT - cmpOp CharLeOp = LE - cmpOp IntGtOp = GT - cmpOp IntGeOp = GE - cmpOp IntEqOp = EQ - cmpOp IntNeOp = NE - cmpOp IntLtOp = LT - cmpOp IntLeOp = LE - cmpOp WordGtOp = NE - cmpOp WordGeOp = ALWAYS - cmpOp WordEqOp = EQ - cmpOp WordNeOp = NE - cmpOp WordLtOp = NEVER - cmpOp WordLeOp = EQ - cmpOp AddrGtOp = NE - cmpOp AddrGeOp = ALWAYS - cmpOp AddrEqOp = EQ - cmpOp AddrNeOp = NE - cmpOp AddrLtOp = NEVER - cmpOp AddrLeOp = EQ - -genCondJump lbl (StPrim op [x, StDouble 0.0]) = - getReg x `thenUs` \ register -> - getNewRegNCG (registerKind register) - `thenUs` \ tmp -> - let - code = registerCode register tmp - value = registerName register tmp - pk = registerKind register - target = ImmCLbl lbl - in - returnUs (code . mkSeqInstr (BF (cmpOp op) value target)) - where - cmpOp FloatGtOp = GT - cmpOp FloatGeOp = GE - cmpOp FloatEqOp = EQ - cmpOp FloatNeOp = NE - cmpOp FloatLtOp = LT - cmpOp FloatLeOp = LE - cmpOp DoubleGtOp = GT - cmpOp DoubleGeOp = GE - cmpOp DoubleEqOp = EQ - cmpOp DoubleNeOp = NE - cmpOp DoubleLtOp = LT - cmpOp DoubleLeOp = LE - -genCondJump lbl (StPrim op args) - | fltCmpOp op = - trivialFCode instr args `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - let - code = registerCode register tmp - result = registerName register tmp - target = ImmCLbl lbl - in - 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 - (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) - -genCondJump lbl (StPrim op args) = - trivialCode instr args `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> - let - code = registerCode register tmp - result = registerName register tmp - target = ImmCLbl lbl - in - 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) - -\end{code} - -Now the biggest nightmare---calls. Most of the nastiness is buried in -getCallArg, which moves the arguments to the correct registers/stack -locations. Apart from that, the code is easy. - -\begin{code} - -genCCall - :: FAST_STRING -- function to call - -> PrimRep -- type of the result - -> [StixTree] -- arguments (of mixed type) - -> UniqSM (CodeBlock AlphaInstr) - -genCCall fn kind args = - 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, - LDGP gp (AddrReg ra)] - where - 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} - -Trivial (dyadic) instructions. Only look for constants on the right hand -side, because that's where the generic optimizer will have put them. - -\begin{code} - -trivialCode - :: (Reg -> RI -> Reg -> AlphaInstr) - -> [StixTree] - -> UniqSM Register - -trivialCode instr [x, StInt y] - | is8Bits y = - 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 - returnUs (Any IntRep code__2) - -trivialCode instr [x, y] = - 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 (instr src1 (RIReg src2) dst) - in - returnUs (Any IntRep code__2) - -trivialFCode - :: (Reg -> Reg -> Reg -> AlphaInstr) - -> [StixTree] - -> UniqSM Register - -trivialFCode instr [x, y] = - 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 - - code2 = registerCode register2 tmp2 - src2 = registerName register2 tmp2 - - code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (instr src1 src2 dst) - in - 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, -so we need to wrangle an integer register out of things. - -\begin{code} -intNECode - :: [StixTree] - -> UniqSM Register - -intNECode args = - 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 - returnUs (Any IntRep code__2) - -cmpFCode - :: (Reg -> Reg -> Reg -> AlphaInstr) - -> Cond - -> [StixTree] - -> UniqSM Register - -cmpFCode instr cond args = - trivialFCode instr args `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - getUniqLabelNCG `thenUs` \ lbl -> - let - code = registerCode register tmp - result = registerName register tmp - - code__2 dst = code . mkSeqInstrs [ - OR zero (RIImm (ImmInt 1)) dst, - BF cond result (ImmCLbl lbl), - OR zero (RIReg zero) dst, - LABEL lbl] - in - returnUs (Any IntRep code__2) - -\end{code} - -Trivial unary instructions. Note that we don't have to worry about -matching an StInt as the argument, because genericOpt will already -have handled the constant-folding. - -\begin{code} - -trivialUCode - :: (RI -> Reg -> AlphaInstr) - -> [StixTree] - -> UniqSM Register - -trivialUCode instr [x] = - 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 - returnUs (Any IntRep code__2) - -trivialUFCode - :: (Reg -> Reg -> AlphaInstr) - -> [StixTree] - -> UniqSM Register - -trivialUFCode instr [x] = - 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 - returnUs (Any DoubleRep code__2) - -\end{code} - -Simple 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 :: PrimRep -> [StixTree] -> UniqSM Register -coerceIntCode pk [x] = - getReg x `thenUs` \ register -> - case register of - Fixed reg _ code -> returnUs (Fixed reg pk code) - Any _ code -> returnUs (Any pk code) - -coerceFltCode :: [StixTree] -> UniqSM Register -coerceFltCode [x] = - getReg x `thenUs` \ register -> - case register of - Fixed reg _ code -> returnUs (Fixed reg DoubleRep code) - Any _ code -> returnUs (Any DoubleRep code) - -\end{code} - -Integer to character conversion. - -\begin{code} - -chrCode [x] = - 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 - returnUs (Any IntRep code__2) - -\end{code} - -More complicated integer/float conversions. Here we have to store -temporaries in memory to move between the integer and the floating -point register sets. - -\begin{code} - -coerceInt2FP :: [StixTree] -> UniqSM Register -coerceInt2FP [x] = - getReg x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> - let - code = registerCode register reg - src = registerName register reg - - code__2 dst = code . mkSeqInstrs [ - ST Q src (spRel 0), - LD TF dst (spRel 0), - CVTxy Q TF dst dst] - in - returnUs (Any DoubleRep code__2) - -coerceFP2Int :: [StixTree] -> UniqSM Register -coerceFP2Int [x] = - getReg x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - - code__2 dst = code . mkSeqInstrs [ - CVTxy TF Q src tmp, - ST TF tmp (spRel 0), - LD Q dst (spRel 0)] - in - returnUs (Any IntRep code__2) - -\end{code} - -Some random little helpers. - -\begin{code} - -is8Bits :: Integer -> Bool -is8Bits i = i >= -256 && i < 256 - -maybeImm :: StixTree -> Maybe Imm -maybeImm (StInt i) - | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i)) - | otherwise = Just (ImmInteger i) -maybeImm (StLitLbl s) = Just (ImmLab s) -maybeImm (StLitLit s) = Just (strImmLab (cvtLitLit (_UNPK_ s))) -maybeImm (StCLbl l) = Just (ImmCLbl l) -maybeImm _ = Nothing - -mangleIndexTree :: StixTree -> StixTree - -mangleIndexTree (StIndex pk base (StInt i)) = - StPrim IntAddOp [base, off] - where - off = StInt (i * size pk) - 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) = - case pk of - CharRep -> StPrim IntAddOp [base, off] - _ -> StPrim IntAddOp [base, off__2] - where - off__2 = StPrim SllOp [off, StInt 3] - -cvtLitLit :: String -> String -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 - | isHex s = s - | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''") - where - isHex ('0':'x':xs) = all isHexDigit xs - isHex _ = False - -- Now, where have I seen this before? - isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' - - -\end{code} - -spRel gives us a stack relative addressing mode for volatile temporaries -and for excess call arguments. - -\begin{code} - -spRel - :: Int -- desired stack offset in words, positive or negative - -> Addr -spRel n = AddrRegImm sp (ImmInt (n * 8)) - -stackArgLoc = 0 :: Int -- where to stack extra call arguments (beyond 6) - -\end{code} - -\begin{code} - -getNewRegNCG :: PrimRep -> UniqSM Reg -getNewRegNCG pk = - getUnique `thenUs` \ u -> - returnUs (mkReg u pk) - -\end{code} diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index da0d83b..ac259c4 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -1,158 +1,128 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \begin{code} #include "HsVersions.h" -#include "../../includes/platform.h" -#include "../../includes/GhcConstants.h" - -module AsmCodeGen ( - writeRealAsm, - dumpRealAsm, - - -- And, I guess we need these... - AbstractC, GlobalSwitch, SwitchResult, - UniqSupply, UniqSM(..) - ) where - -import AbsCSyn ( AbstractC ) -import AbsCStixGen ( genCodeAbstractC ) -import PrelInfo ( PrimRep, PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) ) -import MachDesc -import Maybes ( Maybe(..) ) -import Outputable -#if alpha_TARGET_ARCH -import AlphaDesc ( mkAlpha ) -#endif -#if i386_TARGET_ARCH -import I386Desc ( mkI386 ) -#endif -#if sparc_TARGET_ARCH -import SparcDesc ( mkSparc ) -#endif -import Stix -import UniqSupply -import Unpretty -import Util + +module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where + +import Ubiq{-uitous-} + +import MachMisc +import MachRegs +import MachCode +import PprMach + +import AbsCStixGen ( genCodeAbstractC ) +import AbsCSyn ( AbstractC, MagicId ) +import AsmRegAlloc ( runRegAllocate ) +import OrdList ( OrdList ) +import PrimOp ( commutableOp, PrimOp(..) ) +import PrimRep ( PrimRep{-instance Eq-} ) +import RegAllocInfo ( mkMRegsState, MRegsState ) +import Stix ( StixTree(..), StixReg(..), CodeSegment ) +import UniqSupply ( returnUs, thenUs, mapUs, UniqSM(..) ) +import Unpretty ( uppAppendFile, uppShow, uppAboves, Unpretty(..) ) \end{code} -This is a generic assembly language generator for the Glasgow Haskell -Compiler. It has been a long time in germinating, basically due to -time constraints and the large spectrum of design possibilities. -Presently it generates code for: -\begin{itemize} -\item Sparc -\end{itemize} -In the pipeline (sic) are plans and/or code for 680x0, 386/486. - -The code generator presumes the presence of a working C port. This is -because any code that cannot be compiled (e.g. @casm@s) is re-directed -via this route. It also help incremental development. Because this -code generator is specially written for the Abstract C produced by the -Glasgow Haskell Compiler, several optimisation opportunities are open -to us that are not open to @gcc@. In particular, we know that the A -and B stacks and the Heap are all mutually exclusive wrt. aliasing, -and that expressions have no side effects (all state transformations -are top level objects). - -There are two main components to the code generator. -\begin{itemize} -\item Abstract C is considered in statements, - 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} -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 -allows limited abstraction of different machines from the Main module. - -The first part is the actual assembly language generation. First we -split up the Abstract C into individual functions, then consider -chunks in isolation, giving back an @OrdList@ of assembly language -instructions. The generic algorithm is heavily inspired by Twig -(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] - | - r1 -@ -where @r1,r2@ are registers, and @i@ is an indirection. The Twig -bit twiddling algorithm for tree matching has been abandoned. It is -replaced with a more direct scheme. This is because, after careful -consideration it is felt that the overhead of handling many bit -patterns would be heavier that simply looking at the syntax of the -tree at the node being considered, and dynamically choosing and -pruning rules. - -The ultimate result of the first part is a Set of ordering lists of -ordering lists of assembly language instructions (yes, really!), where -each element in the set is basic chunk. Now several (generic) -simplifications and transformations can be performed. This includes -ones that turn the the ordering of orderings into just a single -ordering list. (The equivalent of applying @concat@ to a list of -lists.) A lot of the re-ordering and optimisation is actually done -(generically) here! The final part, the scheduler, can now be used on -this structure. The code sequence is optimised (obviously) to avoid -stalling the pipeline. This part {\em has} to be heavily machine -dependent. - -[The above seems to describe mostly dreamware. -- JSM] - -The flag that needs to be added is -fasm- where platform is one of -the choices below. +The 96/03 native-code generator has machine-independent and +machine-dependent modules (those \tr{#include}'ing \tr{NCG.h}). + +This module (@AsmCodeGen@) is the top-level machine-independent +module. It uses @AbsCStixGen.genCodeAbstractC@ to produce @StixTree@s +(defined in module @Stix@), using support code from @StixInfo@ (info +tables), @StixPrim@ (primitive operations), @StixMacro@ (Abstract C +macros), and @StixInteger@ (GMP arbitrary-precision operations). + +Before entering machine-dependent land, we do some machine-independent +@genericOpt@imisations (defined below) on the @StixTree@s. + +We convert to the machine-specific @Instr@ datatype with +@stmt2Instrs@, assuming an ``infinite'' supply of registers. We then +use a machine-independent register allocator (@runRegAllocate@) to +rejoin reality. Obviously, @runRegAllocate@ has machine-specific +helper functions (see about @RegAllocInfo@ below). + +The machine-dependent bits break down as follows: +\begin{description} +\item[@MachRegs@:] Everything about the target platform's machine + registers (and immediate operands, and addresses, which tend to + intermingle/interact with registers). + +\item[@MachMisc@:] Includes the @Instr@ datatype (possibly should + have a module of its own), plus a miscellany of other things + (e.g., @targetDoubleSize@, @smStablePtrTable@, ...) + +\item[@MachCode@:] @stmt2Instrs@ is where @Stix@ stuff turns into + machine instructions. +\item[@PprMach@:] @pprInstr@ turns an @Instr@ into text (well, really + an @Unpretty@). + +\item[@RegAllocInfo@:] In the register allocator, we manipulate + @MRegsState@s, which are @BitSet@s, one bit per machine register. + When we want to say something about a specific machine register + (e.g., ``it gets clobbered by this instruction''), we set/unset + its bit. Obviously, we do this @BitSet@ thing for efficiency + reasons. + + The @RegAllocInfo@ module collects together the machine-specific + info needed to do register allocation. +\end{description} + +So, here we go: \begin{code} -writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> UniqSupply -> PrimIO () +writeRealAsm :: _FILE -> AbstractC -> UniqSupply -> IO () -writeRealAsm flags file absC uniq_supply - = uppAppendFile file 80 (runNCG (code flags absC) uniq_supply) +writeRealAsm file absC us + = uppAppendFile file 80 (runNCG absC us) -dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> UniqSupply -> String +dumpRealAsm :: AbstractC -> UniqSupply -> String -dumpRealAsm flags absC uniq_supply = uppShow 80 (runNCG (code flags absC) uniq_supply) +dumpRealAsm absC us = uppShow 80 (runNCG absC us) -runNCG m uniq_supply = m uniq_supply +runNCG absC + = genCodeAbstractC absC `thenUs` \ treelists -> + let + stix = map (map genericOpt) treelists + in + codeGen stix +\end{code} -code flags absC = - genCodeAbstractC target absC `thenUs` \ treelists -> +@codeGen@ is the top-level code-generation function: +\begin{code} +codeGen :: [[StixTree]] -> UniqSM Unpretty + +codeGen trees + = mapUs genMachCode trees `thenUs` \ dynamic_codes -> let - stix = map (map (genericOpt target)) treelists + static_instrs = scheduleMachCode dynamic_codes in - codeGen {-target-} sty stix - where - sty = PprForAsm (switchIsOn flags) (underscore {-target-}) (fmtAsmLbl {-target-}) - - (target, codeGen, underscore, fmtAsmLbl) - = case stringSwitchSet flags AsmTarget of -#if ! OMIT_NATIVE_CODEGEN -# if alpha_TARGET_ARCH - Just _ {-???"alpha-dec-osf1"-} -> mkAlpha flags -# endif -# if i386_TARGET_ARCH - Just _ {-???"i386_unknown_linuxaout"-} -> mkI386 True flags -# endif -# if sparc_sun_sunos4_TARGET - Just _ {-???"sparc-sun-sunos4"-} -> mkSparc True flags -# endif -# if sparc_sun_solaris2_TARGET - Just _ {-???"sparc-sun-solaris2"-} -> mkSparc False flags -# endif -#endif - _ -> error - ("ERROR:Trying to generate assembly language for an unsupported architecture\n"++ - "(or one for which this build is not configured).") + returnUs (uppAboves (map pprInstr static_instrs)) +\end{code} +Top level code generator for a chunk of stix code: +\begin{code} +genMachCode :: [StixTree] -> UniqSM InstrList + +genMachCode stmts + = mapUs stmt2Instrs stmts `thenUs` \ blocks -> + returnUs (foldr (.) id blocks asmVoid) +\end{code} + +The next bit does the code scheduling. The scheduler must also deal +with register allocation of temporaries. Much parallelism can be +exposed via the OrdList, but more might occur, so further analysis +might be needed. + +\begin{code} +scheduleMachCode :: [InstrList] -> [Instr] + +scheduleMachCode + = concat . map (runRegAllocate freeRegsState reservedRegs) + where + freeRegsState = mkMRegsState (extractMappedRegNos freeRegs) \end{code} %************************************************************************ @@ -161,128 +131,108 @@ code flags absC = %* * %************************************************************************ -This is called between translating Abstract C to its Tree -and actually using the Native Code Generator to generate -the annotations. It's a chance to do some strength reductions. +This is called between translating Abstract C to its Tree and actually +using the Native Code Generator to generate the annotations. It's a +chance to do some strength reductions. ** Remember these all have to be machine independent *** -Note that constant-folding should have already happened, but we might have -introduced some new opportunities for constant-folding wrt address manipulations. +Note that constant-folding should have already happened, but we might +have introduced some new opportunities for constant-folding wrt +address manipulations. \begin{code} - -genericOpt - :: Target - -> StixTree - -> StixTree - +genericOpt :: StixTree -> StixTree \end{code} For most nodes, just optimize the children. \begin{code} --- hacking with Uncle Will: -#define target_STRICT target@(Target _ _ _ _ _ _ _ _) - -genericOpt target_STRICT (StInd pk addr) = - StInd pk (genericOpt target addr) - -genericOpt target (StAssign pk dst src) = - StAssign pk (genericOpt target dst) (genericOpt target src) +genericOpt (StInd pk addr) = StInd pk (genericOpt addr) -genericOpt target (StJump addr) = - StJump (genericOpt target addr) +genericOpt (StAssign pk dst src) + = StAssign pk (genericOpt dst) (genericOpt src) -genericOpt target (StCondJump addr test) = - StCondJump addr (genericOpt target test) +genericOpt (StJump addr) = StJump (genericOpt addr) -genericOpt target (StCall fn pk args) = - StCall fn pk (map (genericOpt target) args) +genericOpt (StCondJump addr test) + = StCondJump addr (genericOpt test) +genericOpt (StCall fn pk args) + = StCall fn pk (map genericOpt args) \end{code} -Fold indices together when the types match. - +Fold indices together when the types match: \begin{code} +genericOpt (StIndex pk (StIndex pk' base off) off') + | pk == pk' + = StIndex pk (genericOpt base) + (genericOpt (StPrim IntAddOp [off, off'])) -genericOpt target (StIndex pk (StIndex pk' base off) off') - | pk == pk' = - StIndex pk (genericOpt target base) - (genericOpt target (StPrim IntAddOp [off, off'])) - -genericOpt target (StIndex pk base off) = - StIndex pk (genericOpt target base) - (genericOpt target off) - +genericOpt (StIndex pk base off) + = StIndex pk (genericOpt base) (genericOpt off) \end{code} -For primOps, we first optimize the children, and then we try our hand +For PrimOps, we first optimize the children, and then we try our hand at some constant-folding. \begin{code} - -genericOpt target (StPrim op args) = - primOpt op (map (genericOpt target) args) - +genericOpt (StPrim op args) = primOpt op (map genericOpt args) \end{code} -Replace register leaves with appropriate StixTrees for the given target. -(Oh, so this is why we've been hauling the target around!) +Replace register leaves with appropriate StixTrees for the given +target. \begin{code} +genericOpt leaf@(StReg (StixMagicId id)) + = case (stgReg id) of + Always tree -> genericOpt tree + Save _ -> leaf -genericOpt target leaf@(StReg (StixMagicId id)) = - case stgReg target id of - Always tree -> genericOpt target tree - Save _ -> leaf - -genericOpt target other = other - +genericOpt other = other \end{code} -Now, try to constant-fold the primOps. The arguments have -already been optimized and folded. +Now, try to constant-fold the PrimOps. The arguments have already +been optimized and folded. \begin{code} - primOpt :: PrimOp -- The operation from an StPrim -> [StixTree] -- The optimized arguments -> StixTree -primOpt op arg@[StInt x] = - case op of +primOpt op arg@[StInt x] + = case op of IntNegOp -> StInt (-x) IntAbsOp -> StInt (abs x) _ -> StPrim op arg -primOpt op args@[StInt x, StInt y] = - case op of - CharGtOp -> StInt (if x > y then 1 else 0) +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) CharEqOp -> StInt (if x == y then 1 else 0) CharNeOp -> StInt (if x /= y then 1 else 0) - CharLtOp -> StInt (if x < y then 1 else 0) + CharLtOp -> StInt (if x < y then 1 else 0) CharLeOp -> StInt (if x <= y then 1 else 0) IntAddOp -> StInt (x + y) IntSubOp -> StInt (x - y) IntMulOp -> StInt (x * y) IntQuotOp -> StInt (x `quot` y) IntRemOp -> StInt (x `rem` y) - IntGtOp -> StInt (if x > y then 1 else 0) + IntGtOp -> StInt (if x > y then 1 else 0) IntGeOp -> StInt (if x >= y then 1 else 0) IntEqOp -> StInt (if x == y then 1 else 0) IntNeOp -> StInt (if x /= y then 1 else 0) - IntLtOp -> StInt (if x < y then 1 else 0) + IntLtOp -> StInt (if x < y then 1 else 0) IntLeOp -> StInt (if x <= y then 1 else 0) _ -> StPrim op args - \end{code} When possible, shift the constants to the right-hand side, so that we can match for strength reductions. Note that the code generator will -also assume that constants have been shifted to the right when possible. +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] @@ -291,40 +241,40 @@ primOpt op [x@(StInt _), y] | commutableOp op = primOpt op [y, x] We can often do something with constants of 0 and 1 ... \begin{code} -primOpt op args@[x, y@(StInt 0)] = - case op of +primOpt op args@[x, y@(StInt 0)] + = case op of IntAddOp -> x IntSubOp -> x IntMulOp -> y - AndOp -> y - OrOp -> x - SllOp -> x - SraOp -> x - SrlOp -> x - ISllOp -> x - ISraOp -> x - ISrlOp -> x - _ -> StPrim op args - -primOpt op args@[x, y@(StInt 1)] = - case op of - IntMulOp -> x + AndOp -> y + OrOp -> x + SllOp -> x + SraOp -> x + SrlOp -> x + ISllOp -> x + ISraOp -> x + ISrlOp -> x + _ -> StPrim op args + +primOpt op args@[x, y@(StInt 1)] + = case op of + IntMulOp -> x IntQuotOp -> x - IntRemOp -> StInt 0 - _ -> StPrim op args + IntRemOp -> StInt 0 + _ -> StPrim op args \end{code} Now look for multiplication/division by powers of 2 (integers). \begin{code} -primOpt op args@[x, y@(StInt n)] = - case op of - IntMulOp -> case exact_log2 n of +primOpt op args@[x, y@(StInt n)] + = case op of + IntMulOp -> case exactLog2 n of Nothing -> StPrim op args - Just p -> StPrim SllOp [x, StInt p] - IntQuotOp -> case exact_log2 n of + Just p -> StPrim SllOp [x, StInt p] + IntQuotOp -> case exactLog2 n of Nothing -> StPrim op args - Just p -> StPrim SraOp [x, StInt p] + Just p -> StPrim SraOp [x, StInt p] _ -> StPrim op args \end{code} @@ -333,52 +283,3 @@ 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. - -\begin{code} -commutableOp :: PrimOp -> Bool - -commutableOp CharEqOp = True -commutableOp CharNeOp = True -commutableOp IntAddOp = True -commutableOp IntMulOp = True -commutableOp AndOp = True -commutableOp OrOp = True -commutableOp IntEqOp = True -commutableOp IntNeOp = True -commutableOp IntegerAddOp = True -commutableOp IntegerMulOp = True -commutableOp FloatAddOp = True -commutableOp FloatMulOp = True -commutableOp FloatEqOp = True -commutableOp FloatNeOp = True -commutableOp DoubleAddOp = True -commutableOp DoubleMulOp = 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. - -\begin{code} -w2i x = word2Int# x -i2w x = int2Word# x -i2w_s x = (x::Int#) - -exact_log2 :: Integer -> Maybe Integer -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 - else Just (toInteger (I# (pow2 x#))) - - where pow2 x# | x# ==# 1# = 0# - | otherwise = 1# +# pow2 (w2i (i2w x# `shiftr` i2w_s 1#)) - - shiftr x y = shiftRA# x y -\end{code} diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 29061de..8e574e6 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -1,238 +1,57 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % +\section[AsmRegAlloc]{Register allocator} \begin{code} #include "HsVersions.h" -#include "../../includes/platform.h" -#include "../../includes/GhcConstants.h" -module AsmRegAlloc ( - FutureLive(..), RegLiveness(..), RegUsage(..), Reg(..), - MachineRegisters(..), MachineCode(..), +module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where - mkReg, runRegAllocate, runHairyRegAllocate, - extractMappedRegNos +import Ubiq{-uitous-} - -- And, for self-sufficiency - ) where +import MachCode ( InstrList(..) ) +import MachMisc ( Instr ) +import MachRegs +import RegAllocInfo -import CLabel ( CLabel ) -import FiniteMap -import MachDesc -import Maybes ( maybeToBool, Maybe(..) ) -import OrdList -- ( mkUnitList, mkSeqList, mkParList, OrdList ) -import Outputable -import Pretty -import UniqSet -import Unique ( Unique ) -import Util - -#if ! OMIT_NATIVE_CODEGEN - -# if alpha_TARGET_ARCH -import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing - -{-# SPECIALIZE - runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr] - #-} -# endif - -# if i386_TARGET_ARCH -import I386Code -- ( I386Instr, I386Regs ) -- for specializing - -{-# SPECIALIZE - runRegAllocate :: I386Regs -> [Int] -> (OrdList I386Instr) -> [I386Instr] - #-} -# endif - -# if sparc_TARGET_ARCH -import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing - -{-# SPECIALIZE - runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr] - #-} -# endif - -#endif - -\end{code} - -%************************************************************************ -%* * -\subsection[Reg]{Real registers} -%* * -%************************************************************************ - -Static Registers correspond to actual machine registers. These should -be avoided until the last possible moment. - -Dynamic registers are allocated on the fly, usually to represent a single -value in the abstract assembly code (i.e. dynamic registers are usually -single assignment). Ultimately, they are mapped to available machine -registers before spitting out the code. - -\begin{code} - -data Reg = FixedReg FAST_INT -- A pre-allocated machine register - - | MappedReg FAST_INT -- A dynamically allocated machine register - - | MemoryReg Int PrimRep -- A machine "register" actually held in a memory - -- allocated table of registers which didn't fit - -- in real 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 -> PrimRep -> Reg -mkReg = UnmappedReg - -instance Text Reg where - showsPrec _ (FixedReg i) = showString "%" . shows IBOX(i) - showsPrec _ (MappedReg i) = showString "%" . shows IBOX(i) - showsPrec _ (MemoryReg i _) = showString "%M" . shows i - showsPrec _ (UnmappedReg i _) = showString "%U" . shows i - -#ifdef DEBUG -instance Outputable Reg where - ppr sty r = ppStr (show r) -#endif - -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' _) = cmp u u' -cmpReg r1 r2 = - let tag1 = tagReg r1 - tag2 = tagReg r2 - in - if tag1 _LT_ tag2 then LT_ else GT_ - where - tagReg (FixedReg _) = (ILIT(1) :: FAST_INT) - tagReg (MappedReg _) = ILIT(2) - tagReg (MemoryReg _ _) = ILIT(3) - tagReg (UnmappedReg _ _) = ILIT(4) - -cmp_i :: Int -> Int -> TAG_ -cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_ - -cmp_ihash :: FAST_INT -> FAST_INT -> TAG_ -cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_ - -instance Eq Reg where - a == b = case cmpReg a b of { EQ_ -> True; _ -> False } - a /= b = case cmpReg a b of { EQ_ -> False; _ -> True } - -instance Ord Reg where - a <= b = case cmpReg a b of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case cmpReg a b of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } - -instance NamedThing Reg where - -- the *only* method that should be defined is "getItsUnique"! - -- (so we can use UniqFMs/UniqSets on Regs - getItsUnique (UnmappedReg u _) = u - getItsUnique (FixedReg i) = mkPseudoUnique1 IBOX(i) - getItsUnique (MappedReg i) = mkPseudoUnique2 IBOX(i) - getItsUnique (MemoryReg i _) = mkPseudoUnique3 i +import BitSet ( BitSet ) +import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM ) +import Maybes ( maybeToBool ) +import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList, + flattenOrdList, OrdList + ) +import Stix ( StixTree ) +import UniqSupply ( mkBuiltinUnique ) +import Util ( mapAccumB, panic ) \end{code} This is the generic register allocator. -%************************************************************************ -%* * -\subsection[RegPlace]{Map Stix registers to {\em real} registers} -%* * -%************************************************************************ - -An important point: The @regUsage@ function for a particular assembly language -must not refer to fixed registers, such as Hp, SpA, etc. The source and destination -lists should only refer to dynamically allocated registers or static registers -from the free list. As far as we are concerned, the fixed registers simply don't -exist (for allocation purposes, anyway). - -\begin{code} - -class MachineRegisters a where - mkMRegs :: [Int] -> a - possibleMRegs :: PrimRep -> a -> [Int] - useMReg :: a -> FAST_INT -> a - useMRegs :: a -> [Int] -> a - freeMReg :: a -> FAST_INT -> a - freeMRegs :: a -> [Int] -> a - -type RegAssignment = FiniteMap Reg Reg -type RegConflicts = FiniteMap Int (UniqSet Reg) - -data FutureLive - = FL (UniqSet Reg) - (FiniteMap CLabel (UniqSet Reg)) -fstFL (FL a b) = a - -data RegHistory a - = RH a - Int - RegAssignment - -data RegFuture - = RF (UniqSet Reg) -- in use - FutureLive -- future - RegConflicts - -data RegInfo a - = RI (UniqSet Reg) -- in use - (UniqSet Reg) -- sources - (UniqSet Reg) -- destinations - [Reg] -- last used - RegConflicts - -data RegUsage - = RU (UniqSet Reg) - (UniqSet Reg) - -data RegLiveness - = RL (UniqSet Reg) - FutureLive - -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 -\end{code} - -First we try something extremely simple. -If that fails, we have to do things the hard way. +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 - -> [Int] - -> (OrdList b) - -> [b] - -runRegAllocate regs reserve_regs instrs = - case simpleAlloc of + :: MRegsState + -> [RegNo] + -> InstrList + -> [Instr] + +runRegAllocate regs reserve_regs instrs + = case simpleAlloc of Just x -> x Nothing -> hairyAlloc where flatInstrs = flattenOrdList instrs - simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs - hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs + simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs + hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs runHairyRegAllocate -- use only hairy for i386! - :: (MachineRegisters a, MachineCode b) - => a - -> [Int] - -> (OrdList b) - -> [b] + :: MRegsState + -> [RegNo] + -> InstrList + -> [Instr] runHairyRegAllocate regs reserve_regs instrs = hairyRegAlloc regs reserve_regs flatInstrs @@ -248,25 +67,24 @@ this approach will suffice for about 96 percent of the code blocks that we generate. \begin{code} - simpleRegAlloc - :: (MachineRegisters a, MachineCode b) - => a -- registers to select from + :: MRegsState -- registers to select from -> [Reg] -- live static registers -> RegAssignment -- mapping of dynamics to statics - -> [b] -- code - -> Maybe [b] + -> [Instr] -- code + -> Maybe [Instr] simpleRegAlloc _ _ _ [] = Just [] -simpleRegAlloc free live env (instr:instrs) = - if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then + +simpleRegAlloc free live env (instr:instrs) + = if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then Just (instr3 : instrs3) else Nothing where instr3 = patchRegs instr (lookup env2) - (srcs, dsts) = case regUsage instr of { RU s d -> (uniqSetToList s, uniqSetToList d) } + (srcs, dsts) = case regUsage instr of { RU s d -> (regSetToList s, regSetToList d) } lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x} @@ -284,10 +102,9 @@ simpleRegAlloc free live env (instr:instrs) = instrs3 = case instrs2 of Just x -> x allocateNewReg - :: MachineRegisters a - => Reg - -> Maybe (a, [(Reg, Reg)]) - -> Maybe (a, [(Reg, Reg)]) + :: Reg + -> Maybe (MRegsState, [(Reg, Reg)]) + -> Maybe (MRegsState, [(Reg, Reg)]) allocateNewReg _ Nothing = Nothing @@ -299,7 +116,6 @@ simpleRegAlloc free live env (instr:instrs) = reg = head choices free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} ) prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs) - \end{code} Here is the ``clever'' bit. First go backward (i.e. left), looking for @@ -307,16 +123,14 @@ the last use of dynamic registers. Then go forward (i.e. right), filling registers with static placements. \begin{code} - hairyRegAlloc - :: (MachineRegisters a, MachineCode b) - => a - -> [Int] - -> [b] - -> [b] - -hairyRegAlloc regs reserve_regs instrs = - case mapAccumB (doRegAlloc reserve_regs) + :: MRegsState + -> [RegNo] + -> [Instr] + -> [Instr] + +hairyRegAlloc regs reserve_regs instrs + = case mapAccumB (doRegAlloc reserve_regs) (RH regs' 1 emptyFM) noFuture instrs of (RH _ loc' _, _, instrs') -> if loc' == 1 then instrs' else @@ -325,19 +139,18 @@ hairyRegAlloc regs reserve_regs instrs = of ((RH _ loc'' _),_,instrs'') -> if loc'' == loc' then instrs'' else panic "runRegAllocate" where - regs' = regs `useMRegs` reserve_regs - regs'' = mkMRegs reserve_regs `asTypeOf` regs + regs' = regs `useMRegs` reserve_regs + regs'' = mkMRegsState reserve_regs do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh) do_RegAlloc_Nil - :: (MachineRegisters a, MachineCode b) - => RegHistory a + :: RegHistory MRegsState -> RegFuture - -> b - -> (RegHistory a, RegFuture, b) + -> Instr + -> (RegHistory MRegsState, RegFuture, Instr) noFuture :: RegFuture -noFuture = RF emptyUniqSet (FL emptyUniqSet emptyFM) emptyFM +noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM \end{code} Here we patch instructions that reference ``registers'' which are really in @@ -349,21 +162,14 @@ instructions are rewritten with new dynamic registers, so we have to run registe allocation again after all of this is said and done. \begin{code} - -patchMem - :: MachineCode a - => [a] - -> OrdList a +patchMem :: [Instr] -> InstrList patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs -patchMem' - :: MachineCode a - => a - -> OrdList a +patchMem' :: Instr -> InstrList -patchMem' instr = - if null memSrcs && null memDsts then mkUnitList instr +patchMem' instr + = if null memSrcs && null memDsts then mkUnitList instr else mkSeqList (foldr mkParList mkEmptyList loadSrcs) (mkSeqList instr' @@ -375,8 +181,8 @@ patchMem' instr = memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk memToDyn other = other - memSrcs = [ r | r@(MemoryReg _ _) <- uniqSetToList srcs] - memDsts = [ r | r@(MemoryReg _ _) <- uniqSetToList dsts] + memSrcs = [ r | r@(MemoryReg _ _) <- regSetToList srcs] + memDsts = [ r | r@(MemoryReg _ _) <- regSetToList dsts] loadSrcs = map load memSrcs spillDsts = map spill memDsts @@ -385,62 +191,55 @@ patchMem' instr = spill mem = spillReg (memToDyn mem) mem instr' = mkUnitList (patchRegs instr memToDyn) - \end{code} \begin{code} - doRegAlloc - :: (MachineRegisters a, MachineCode b) - => [Int] - -> RegHistory a + :: [RegNo] + -> RegHistory MRegsState -> RegFuture - -> b - -> (RegHistory a, RegFuture, b) + -> Instr + -> (RegHistory MRegsState, RegFuture, Instr) doRegAlloc reserved_regs free_env in_use instr = (free_env', in_use', instr') where (free_env', instr') = doRegAlloc' reserved_regs free_env info instr (in_use', info) = getUsage in_use instr - \end{code} \begin{code} - getUsage - :: MachineCode a - => RegFuture - -> a - -> (RegFuture, RegInfo a) + :: RegFuture + -> Instr + -> (RegFuture, RegInfo Instr) -getUsage (RF next_in_use future reg_conflicts) instr = - (RF in_use' future' reg_conflicts', +getUsage (RF next_in_use future reg_conflicts) instr + = (RF in_use' future' reg_conflicts', RI in_use' srcs dsts last_used reg_conflicts') where (RU srcs dsts) = regUsage instr (RL in_use future') = regLiveness instr (RL next_in_use future) - live_through = in_use `minusUniqSet` dsts - last_used = [ r | r <- uniqSetToList srcs, - not (r `elementOfUniqSet` (fstFL future) || r `elementOfUniqSet` in_use)] - in_use' = srcs `unionUniqSets` live_through + live_through = in_use `minusRegSet` dsts + last_used = [ r | r <- regSetToList srcs, + not (r `elementOfRegSet` (fstFL future) || r `elementOfRegSet` in_use)] + in_use' = srcs `unionRegSets` live_through reg_conflicts' = case new_conflicts of [] -> reg_conflicts _ -> addListToFM reg_conflicts new_conflicts - new_conflicts = if isEmptyUniqSet live_dynamics then [] + new_conflicts = if isEmptyRegSet live_dynamics then [] else [ (r, merge_conflicts r) - | r <- extractMappedRegNos (uniqSetToList dsts) ] + | r <- extractMappedRegNos (regSetToList dsts) ] merge_conflicts reg = case lookupFM reg_conflicts reg of Nothing -> live_dynamics - Just conflicts -> conflicts `unionUniqSets` live_dynamics - live_dynamics = mkUniqSet - [ r | r@(UnmappedReg _ _) <- uniqSetToList live_through ] + Just conflicts -> conflicts `unionRegSets` live_dynamics + live_dynamics = mkRegSet + [ r | r@(UnmappedReg _ _) <- regSetToList live_through ] doRegAlloc' - :: (MachineRegisters a, MachineCode b) - => [Int] - -> RegHistory a - -> RegInfo b - -> b - -> (RegHistory a, b) + :: [RegNo] + -> RegHistory MRegsState + -> RegInfo Instr + -> Instr + -> (RegHistory MRegsState, Instr) doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr = @@ -449,17 +248,17 @@ doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) inst where -- free up new registers - free :: [Int] + free :: [RegNo] free = extractMappedRegNos (map dynToStatic lastu) -- (1) free registers that are used last as source operands in this instruction - frs_not_in_use = frs `useMRegs` (extractMappedRegNos (uniqSetToList in_use)) + frs_not_in_use = frs `useMRegs` (extractMappedRegNos (regSetToList in_use)) frs' = (frs_not_in_use `freeMRegs` free) `useMRegs` reserved -- (2) allocate new registers for the destination operands -- allocate registers for new dynamics - new_dynamix = [ r | r@(UnmappedReg _ _) <- uniqSetToList dsts, r `not_elem` keysFM env ] + new_dynamix = [ r | r@(UnmappedReg _ _) <- regSetToList dsts, r `not_elem` keysFM env ] (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix @@ -475,8 +274,7 @@ doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) inst dynToStatic other = other allocateNewRegs - :: MachineRegisters a - => Reg -> (a, Int, [(Reg, Reg)]) -> (a, Int, [(Reg, Reg)]) + :: Reg -> (MRegsState, Int, [(Reg, Reg)]) -> (MRegsState, Int, [(Reg, Reg)]) allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst) where (fs', f, mem') = case acceptable fs of @@ -486,17 +284,7 @@ doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) inst acceptable regs = filter no_conflict (possibleMRegs pk regs) no_conflict reg = case lookupFM conflicts reg of Nothing -> True - Just conflicts -> not (d `elementOfUniqSet` conflicts) -\end{code} - -\begin{code} -extractMappedRegNos :: [Reg] -> [Int] - -extractMappedRegNos regs - = foldr ex [] regs - where - ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it - ex _ acc = acc -- leave it out + Just conflicts -> not (d `elementOfRegSet` conflicts) \end{code} We keep a local copy of the Prelude function \tr{notElem}, diff --git a/ghc/compiler/nativeGen/I386Code.lhs b/ghc/compiler/nativeGen/I386Code.lhs deleted file mode 100644 index 2205224..0000000 --- a/ghc/compiler/nativeGen/I386Code.lhs +++ /dev/null @@ -1,1365 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1995 -% - -\section[I386Code]{The Native (I386) Machine Code} - -\begin{code} -#define ILIT2(x) ILIT(x) -#include "HsVersions.h" - -module I386Code ( - Addr(..), - Cond(..), Imm(..), Operand(..), Size(..), - Base(..), Index(..), Displacement(..), - I386Code(..),I386Instr(..),I386Regs, - strImmLit, - spRel, - - printLabeledCodes, - - baseRegOffset, stgRegMap, callerSaves, - - is13Bits, offset, - - kindToSize, - - st0, st1, eax, ebx, ecx, edx, esi, edi, ebp, esp, - - freeRegs, reservedRegs - - -- and, for self-sufficiency ... - ) where - -import AbsCSyn ( MagicId(..) ) -import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..), - Reg(..), RegUsage(..), RegLiveness(..) - ) -import BitSet -import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG ) -import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, charToC ) -import FiniteMap -import Maybes ( Maybe(..), maybeToBool ) -import OrdList ( OrdList, mkUnitList, flattenOrdList ) -import Outputable -import UniqSet -import Stix -import Unpretty -import Util -\end{code} - -%************************************************************************ -%* * -\subsection[I386Reg]{The Native (I386) Machine Register Table} -%* * -%************************************************************************ - -- All registers except 7 (esp) are available for use. -- Only ebx, esi, edi and esp are available across a C call (they are callee-saves). -- Registers 0-7 have 16-bit counterparts (ax, bx etc.) -- Registers 0-3 have 8 bit counterparts (ah, bh etc.) -- Registers 8-15 hold extended floating point values. - -ToDo: Deal with stg registers that live as offsets from BaseReg!(JSM) - -\begin{code} - -gReg,fReg :: Int -> Int -gReg x = x -fReg x = (8 + x) - -st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg -eax = case (gReg 0) of { IBOX(g0) -> FixedReg g0 } -ebx = case (gReg 1) of { IBOX(g1) -> FixedReg g1 } -ecx = case (gReg 2) of { IBOX(g2) -> FixedReg g2 } -edx = case (gReg 3) of { IBOX(g3) -> FixedReg g3 } -esi = case (gReg 4) of { IBOX(g4) -> FixedReg g4 } -edi = case (gReg 5) of { IBOX(g5) -> FixedReg g5 } -ebp = case (gReg 6) of { IBOX(g6) -> FixedReg g6 } -esp = case (gReg 7) of { IBOX(g7) -> FixedReg g7 } -st0 = realReg (fReg 0) -st1 = realReg (fReg 1) -st2 = realReg (fReg 2) -st3 = realReg (fReg 3) -st4 = realReg (fReg 4) -st5 = realReg (fReg 5) -st6 = realReg (fReg 6) -st7 = realReg (fReg 7) - -realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i - -\end{code} - -%************************************************************************ -%* * -\subsection[TheI386Code]{The datatype for i386 assembly language} -%* * -%************************************************************************ - -Here is a definition of the I386 assembly language. - -\begin{code} - -data Imm = ImmInt Int - | ImmInteger Integer -- Sigh. - | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLab Unpretty -- Simple string label (underscored) - | ImmLit Unpretty -- Simple string - deriving () - -strImmLit s = ImmLit (uppStr s) - -data Cond = ALWAYS - | GEU - | LU - | EQ - | GT - | GE - | GU - | LT - | LE - | LEU - | NE - | NEG - | POS - deriving () - - -data Size = B - | HB - | S -- unused ? - | L - | F - | D - deriving () - -data Operand = OpReg Reg -- register - | OpImm Imm -- immediate value - | OpAddr Addr -- memory reference - deriving () - -data Addr = Addr Base Index Displacement - | ImmAddr Imm Int - -- deriving Eq - -type Base = Maybe Reg -type Index = Maybe (Reg, Int) -- Int is 2, 4 or 8 -type Displacement = Imm - -data I386Instr = - --- Moves. - - 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 - --- Int Arithmetic. - - | ADD Size Operand Operand - | SUB Size Operand Operand - --- Multiplication (signed and unsigned), Division (signed and unsigned), --- result in %eax, %edx. - - | IMUL Size Operand Operand - | IDIV Size Operand - --- Simple bit-twiddling. - - | 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 - --- Float Arithmetic. -- ToDo for 386 - --- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions --- right up until we spit them out. - - | SAHF -- stores ah into flags - | FABS - | FADD Size Operand -- src - | FADDP - | FIADD Size Addr -- src - | FCHS - | FCOM Size Operand -- src - | FCOS - | FDIV Size Operand -- src - | FDIVP - | FIDIV Size Addr -- src - | FDIVR Size Operand -- src - | 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 - | FMUL Size Operand -- src - | FMULP - | FIMUL Size Addr -- src - | FRNDINT - | FSIN - | FSQRT - | FST Size Operand -- dst - | FSTP Size Operand -- dst - | FSUB Size Operand -- src - | FSUBP - | FISUB Size Addr -- src - | FSUBR Size Operand -- src - | FSUBRP - | FISUBR Size Addr -- src - | FTST - | FCOMP Size Operand -- src - | FUCOMPP - | FXCH - | FNSTSW - | FNOP - --- Comparison - - | TEST Size Operand Operand - | CMP Size Operand Operand - | SETCC Cond Operand - --- Stack Operations. - - | PUSH Size Operand - | POP Size Operand - --- Jumping around. - - | JMP Operand -- target - | JXX Cond CLabel -- target - | CALL Imm - --- Other things. - - | CLTD -- sign extend %eax into %edx:%eax - --- Pseudo-ops. - - | LABEL CLabel - | COMMENT FAST_STRING - | SEGMENT CodeSegment - | ASCII Bool String -- needs backslash conversion? - | DATA Size [Imm] - -type I386Code = OrdList I386Instr - -\end{code} - -%************************************************************************ -%* * -\subsection[TheI386Pretty]{Pretty-printing the I386 Assembly Language} -%* * -%************************************************************************ - -\begin{code} - -printLabeledCodes :: PprStyle -> [I386Instr] -> Unpretty -printLabeledCodes sty codes = uppAboves (map (pprI386Instr sty) codes) - -\end{code} - -Printing the pieces... - -\begin{code} - -pprReg :: Size -> Reg -> Unpretty - -pprReg s (FixedReg i) = pprI386Reg s i -pprReg s (MappedReg i) = pprI386Reg s i -pprReg s other = uppStr (show other) -- should only happen when debugging - -pprI386Reg :: Size -> FAST_INT -> Unpretty -pprI386Reg B i = uppPStr - (case i of { - 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( 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( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx"); - 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( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx"); - 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(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)"); - 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(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)"); - 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") - }) - -pprCond :: Cond -> Unpretty -- ToDo -pprCond x = uppPStr - (case x of { - GEU -> SLIT("ae"); LU -> SLIT("b"); - EQ -> SLIT("e"); GT -> SLIT("g"); - GE -> SLIT("ge"); GU -> SLIT("a"); - LT -> SLIT("l"); LE -> SLIT("le"); - LEU -> SLIT("be"); NE -> SLIT("ne"); - NEG -> SLIT("s"); POS -> SLIT("ns"); - ALWAYS -> SLIT("mp"); -- hack - _ -> error "Spix: iI386Code: unknown conditional!" - }) - -pprDollImm :: PprStyle -> Imm -> Unpretty - -pprDollImm sty i = uppBesides [ uppPStr SLIT("$"), pprImm sty i] - -pprImm :: PprStyle -> Imm -> Unpretty - -pprImm sty (ImmInt i) = uppInt i -pprImm sty (ImmInteger i) = uppInteger i -pprImm sty (ImmCLbl l) = pprCLabel sty l -pprImm sty (ImmLab l) = l - ---pprImm (PprForAsm _ False _) (ImmLab s) = s ---pprImm _ (ImmLab s) = uppBeside (uppChar '_') s - -pprImm sty (ImmLit s) = s - -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 - ] -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 ')' - ] - where - pprBase (Just r) = uppBesides [pprReg L r, - case index of - Nothing -> uppPStr SLIT("") - _ -> uppChar ',' - ] - pprBase _ = uppPStr SLIT("") - pprIndex (Just (r,i)) = uppBesides [pprReg L r, uppChar ',', uppInt i] - pprIndex _ = uppPStr SLIT("") - -pprDisp sty (ImmInt 0) = uppPStr SLIT("") ---pprDisp sty (ImmInteger 0) = uppPStr SLIT("") -pprDisp sty d = pprImm sty d - -pprOperand :: PprStyle -> Size -> Operand -> Unpretty -pprOperand sty s (OpReg r) = pprReg s r -pprOperand sty s (OpImm i) = pprDollImm sty i -pprOperand sty s (OpAddr ea) = pprAddr sty ea - -pprSize :: Size -> Unpretty -pprSize x = uppPStr - (case x of - B -> SLIT("b") - HB -> SLIT("b") - S -> SLIT("w") - L -> SLIT("l") - F -> SLIT("s") - D -> SLIT("l") - ) - -pprSizeOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Unpretty -pprSizeOp sty name size op1 = - uppBesides [ - uppChar '\t', - uppPStr name, - pprSize size, - uppChar ' ', - pprOperand sty size op1 - ] - -pprSizeOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty -pprSizeOpOp sty name size op1 op2 = - uppBesides [ - uppChar '\t', - uppPStr name, - pprSize size, - uppChar ' ', - pprOperand sty size op1, - uppComma, - pprOperand sty size op2 - ] - -pprSizeOpReg :: PprStyle -> FAST_STRING -> Size -> Operand -> Reg -> Unpretty -pprSizeOpReg sty name size op1 reg = - uppBesides [ - uppChar '\t', - uppPStr name, - pprSize size, - uppChar ' ', - pprOperand sty size op1, - uppComma, - pprReg size reg - ] - -pprSizeAddr :: PprStyle -> FAST_STRING -> Size -> Addr -> Unpretty -pprSizeAddr sty name size op = - uppBesides [ - uppChar '\t', - uppPStr name, - pprSize size, - uppChar ' ', - pprAddr sty op - ] - -pprSizeAddrReg :: PprStyle -> FAST_STRING -> Size -> Addr -> Reg -> Unpretty -pprSizeAddrReg sty name size op dst = - uppBesides [ - uppChar '\t', - uppPStr name, - pprSize size, - uppChar ' ', - pprAddr sty op, - uppComma, - pprReg size dst - ] - -pprOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty -pprOpOp sty name size op1 op2 = - uppBesides [ - uppChar '\t', - uppPStr name, - uppChar ' ', - pprOperand sty size op1, - uppComma, - pprOperand sty size op2 - ] - -pprSizeOpOpCoerce :: PprStyle -> FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty -pprSizeOpOpCoerce sty name size1 size2 op1 op2 = - uppBesides [ uppChar '\t', uppPStr name, uppChar ' ', - pprOperand sty size1 op1, - uppComma, - pprOperand sty size2 op2 - ] - -pprCondInstr :: PprStyle -> FAST_STRING -> Cond -> Unpretty -> Unpretty -pprCondInstr sty name cond arg = - uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppChar ' ', arg] - -pprI386Instr :: PprStyle -> I386Instr -> Unpretty -pprI386Instr sty (MOV size (OpReg src) (OpReg dst)) -- hack - | src == dst - = uppPStr SLIT("") -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)) - | 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)) - | reg2 == reg3 - = pprSizeOpOp sty SLIT("add") size (OpReg reg1) dst -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) - = pprSizeOp sty SLIT("dec") size dst -pprI386Instr sty (ADD size (OpImm (ImmInt 1)) dst) - = pprSizeOp sty SLIT("inc") size 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 (IDIV size op) = pprSizeOp sty SLIT("idiv") size op - -pprI386Instr sty (AND size src dst) = pprSizeOpOp sty SLIT("and") size src dst -pprI386Instr sty (OR size src dst) = pprSizeOpOp sty SLIT("or") size src dst -pprI386Instr sty (XOR size src dst) = pprSizeOpOp sty SLIT("xor") size src dst -pprI386Instr sty (NOT size op) = pprSizeOp sty SLIT("not") size op -pprI386Instr sty (NEGI size op) = pprSizeOp sty SLIT("neg") size op -pprI386Instr sty (SHL size imm dst) = pprSizeOpOp sty SLIT("shl") size imm dst -pprI386Instr sty (SAR size imm dst) = pprSizeOpOp sty SLIT("sar") size imm dst -pprI386Instr sty (SHR size imm dst) = pprSizeOpOp sty SLIT("shr") size imm dst - -pprI386Instr sty (CMP size src dst) = pprSizeOpOp sty SLIT("cmp") size src dst -pprI386Instr sty (TEST size src dst) = pprSizeOpOp sty SLIT("test") size src dst -pprI386Instr sty (PUSH size op) = pprSizeOp sty SLIT("push") size op -pprI386Instr sty (POP size op) = pprSizeOp sty SLIT("pop") size op - -pprI386Instr sty (NOP) = uppPStr SLIT("\tnop") -pprI386Instr sty (CLTD) = uppPStr SLIT("\tcltd") - -pprI386Instr sty (SETCC cond op) = pprCondInstr sty SLIT("set") cond (pprOperand sty B op) - -pprI386Instr sty (JXX cond lab) = pprCondInstr sty SLIT("j") cond (pprCLabel sty lab) - -pprI386Instr sty (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm sty imm) -pprI386Instr sty (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand sty L op) - -pprI386Instr sty (CALL imm) = - uppBesides [ uppPStr SLIT("\tcall "), pprImm sty imm ] - -pprI386Instr sty SAHF = uppPStr SLIT("\tsahf") -pprI386Instr sty FABS = uppPStr SLIT("\tfabs") - -pprI386Instr sty (FADD sz src@(OpAddr _)) - = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppChar ' ', pprOperand sty sz src] -pprI386Instr sty (FADD sz src) - = uppPStr SLIT("\tfadd") -pprI386Instr sty FADDP - = uppPStr SLIT("\tfaddp") -pprI386Instr sty (FMUL sz src) - = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppChar ' ', pprOperand sty sz src] -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) - = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppChar ' ', pprOperand sty sz src] -pprI386Instr sty FDIVP - = uppPStr SLIT("\tfdivp") -pprI386Instr sty (FDIVR sz src) - = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppChar ' ', pprOperand sty sz src] -pprI386Instr sty FDIVRP - = uppPStr SLIT("\tfdivpr") -pprI386Instr sty (FIDIVR size op) = pprSizeAddr sty SLIT("fidivr") size op -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))) - = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprCLabel sty 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 (FIMUL size op) = pprSizeAddr sty SLIT("fimul") size op -pprI386Instr sty FRNDINT = uppPStr SLIT("\tfrndint") -pprI386Instr sty FSIN = uppPStr SLIT("\tfsin") -pprI386Instr sty FSQRT = uppPStr SLIT("\tfsqrt") -pprI386Instr sty (FST sz dst) - = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppChar ' ', pprOperand sty 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) - = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppChar ' ', pprOperand sty sz src] -pprI386Instr sty FSUBP - = uppPStr SLIT("\tfsubp") -pprI386Instr sty (FSUBR size src) - = pprSizeOp sty SLIT("fsubr") size src -pprI386Instr sty FSUBRP - = uppPStr SLIT("\tfsubpr") -pprI386Instr sty (FISUBR size op) - = pprSizeAddr sty SLIT("fisubr") size op -pprI386Instr sty FTST = uppPStr SLIT("\tftst") -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") -pprI386Instr sty FNSTSW = uppPStr SLIT("\tfnstsw %ax") -pprI386Instr sty FNOP = uppPStr SLIT("") - -pprI386Instr sty (LABEL clab) = - uppBesides [ - if (externallyVisibleCLabel clab) then - uppBesides [uppPStr SLIT(".globl "), pprLab, uppChar '\n'] - else - uppNil, - pprLab, - uppChar ':' - ] - where pprLab = pprCLabel sty clab - -pprI386Instr sty (COMMENT s) = uppBeside (uppPStr SLIT("# ")) (uppPStr s) - -pprI386Instr sty (SEGMENT TextSegment) - = uppPStr SLIT(".text\n\t.align 4") - -pprI386Instr sty (SEGMENT DataSegment) - = uppPStr SLIT(".data\n\t.align 2") - -pprI386Instr sty (ASCII False str) = - uppBesides [ - uppStr "\t.asciz \"", - uppStr str, - uppChar '"' - ] - -pprI386Instr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60) - where - 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 [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\"")) - asciify (c:(cs@(d:_))) n | isDigit d = - uppBeside (uppStr (charToC c)) (asciify cs 0) - | otherwise = - uppBeside (uppStr (charToC c)) (asciify cs (n-1)) - -pprI386Instr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs) - where pp_item x = case s of - B -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x) - HB-> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x) - S -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x) - L -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x) - F -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x) - D -> uppBeside (uppPStr SLIT("\t.double\t")) (pprImm sty x) - -\end{code} - -%************************************************************************ -%* * -\subsection[Schedule]{Register allocation information} -%* * -%************************************************************************ - -\begin{code} - -data I386Regs = SRegs BitSet BitSet - -instance MachineRegisters I386Regs where - mkMRegs xs = SRegs (mkBS ints) (mkBS floats') - where - (ints, floats) = partition (< 8) xs - floats' = map (subtract 8) 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 = - if n _LT_ ILIT(8) then SRegs (ints `minusBS` singletonBS IBOX(n)) floats - else SRegs ints (floats `minusBS` singletonBS (IBOX(n _SUB_ ILIT(8)))) - - useMRegs (SRegs ints floats) xs = - SRegs (ints `minusBS` ints') - (floats `minusBS` floats') - where - 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') - (floats `unionBS` floats') - where - SRegs ints' floats' = mkMRegs xs - -instance MachineCode I386Instr where - regUsage = i386RegUsage - regLiveness = i386RegLiveness - patchRegs = i386PatchRegs - - -- We spill just below the stack pointer, leaving two words per spill location. - spillReg dyn (MemoryReg i pk) - = trace "spillsave" - (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))) - ---spRel gives us a stack relative addressing mode for volatile temporaries ---and for excess call arguments. - -spRel - :: Int -- desired stack offset in words, positive or negative - -> Addr -spRel n = Addr (Just esp) Nothing (ImmInt (n * 4)) - -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} - -@i386RegUsage@ returns the sets of src and destination registers used by -a particular instruction. Machine registers that are pre-allocated -to stgRegs are filtered out, because they are uninteresting from a -register allocation standpoint. (We wouldn't want them to end up on -the free list!) - -\begin{code} - -i386RegUsage :: I386Instr -> RegUsage -i386RegUsage instr = case instr of - MOV sz src dst -> usage2 src dst - MOVZX sz src dst -> usage2 src dst - MOVSX sz src dst -> usage2 src dst - LEA sz src dst -> usage2 src dst - ADD sz src dst -> usage2 src dst - SUB sz src dst -> usage2 src dst - IMUL sz src dst -> usage2 src dst - IDIV sz src -> usage (eax:edx:opToReg src) [eax,edx] - AND sz src dst -> usage2 src dst - OR sz src dst -> usage2 src dst - XOR sz src dst -> usage2 src dst - NOT sz op -> usage1 op - NEGI sz op -> usage1 op - SHL sz imm dst -> usage1 dst -- imm has to be an Imm - SAR sz imm dst -> usage1 dst -- imm has to be an Imm - SHR sz imm dst -> usage1 dst -- imm has to be an Imm - PUSH sz op -> usage (opToReg op) [] - POP sz op -> usage [] (opToReg op) - TEST sz src dst -> usage (opToReg src ++ opToReg dst) [] - CMP sz src dst -> usage (opToReg src ++ opToReg dst) [] - SETCC cond op -> usage [] (opToReg op) - JXX cond label -> usage [] [] - JMP op -> usage (opToReg op) freeRegs - CALL imm -> usage [] callClobberedRegs - CLTD -> usage [eax] [edx] - NOP -> usage [] [] - SAHF -> usage [eax] [] - FABS -> usage [st0] [st0] - FADD sz src -> usage (st0:opToReg src) [st0] -- allFPRegs - FADDP -> usage [st0,st1] [st0] -- allFPRegs - FIADD sz asrc -> usage (addrToRegs asrc) [st0] - FCHS -> usage [st0] [st0] - FCOM sz src -> usage (st0:opToReg src) [] - FCOS -> usage [st0] [st0] - FDIV sz src -> usage (st0:opToReg src) [st0] - FDIVP -> usage [st0,st1] [st0] - FDIVRP -> usage [st0,st1] [st0] - FIDIV sz asrc -> usage (addrToRegs asrc) [st0] - FDIVR sz src -> usage (st0:opToReg src) [st0] - FIDIVR sz asrc -> usage (addrToRegs asrc) [st0] - FICOM sz asrc -> usage (addrToRegs asrc) [] - FILD sz asrc dst -> usage (addrToRegs asrc) [dst] -- allFPRegs - FIST sz adst -> usage (st0:addrToRegs adst) [] - FLD sz src -> usage (opToReg src) [st0] -- allFPRegs - FLD1 -> usage [] [st0] -- allFPRegs - FLDZ -> usage [] [st0] -- allFPRegs - FMUL sz src -> usage (st0:opToReg src) [st0] - FMULP -> usage [st0,st1] [st0] - FIMUL sz asrc -> usage (addrToRegs asrc) [st0] - FRNDINT -> usage [st0] [st0] - FSIN -> usage [st0] [st0] - FSQRT -> usage [st0] [st0] - FST sz (OpReg r) -> usage [st0] [r] - FST sz dst -> usage (st0:opToReg dst) [] - FSTP sz (OpReg r) -> usage [st0] [r] -- allFPRegs - FSTP sz dst -> usage (st0:opToReg dst) [] -- allFPRegs - FSUB sz src -> usage (st0:opToReg src) [st0] -- allFPRegs - FSUBR sz src -> usage (st0:opToReg src) [st0] -- allFPRegs - FISUB sz asrc -> usage (addrToRegs asrc) [st0] - FSUBP -> usage [st0,st1] [st0] -- allFPRegs - FSUBRP -> usage [st0,st1] [st0] -- allFPRegs - FISUBR sz asrc -> usage (addrToRegs asrc) [st0] - FTST -> usage [st0] [] - FCOMP sz op -> usage (st0:opToReg op) [st0] -- allFPRegs - FUCOMPP -> usage [st0, st1] [] -- allFPRegs - FXCH -> usage [st0, st1] [st0, st1] - FNSTSW -> usage [] [eax] - _ -> noUsage - - where - - usage2 :: Operand -> Operand -> RegUsage - usage2 op (OpReg reg) = usage (opToReg op) [reg] - usage2 op (OpAddr ea) = usage (opToReg op ++ addrToRegs ea) [] - usage2 op (OpImm imm) = usage (opToReg op) [] - usage1 :: Operand -> RegUsage - usage1 (OpReg reg) = usage [reg] [reg] - 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] - --- General purpose register collecting functions. - - opToReg (OpReg reg) = [reg] - opToReg (OpImm imm) = [] - opToReg (OpAddr ea) = addrToRegs ea - - addrToRegs (Addr base index _) = baseToReg base ++ indexToReg index - where baseToReg Nothing = [] - baseToReg (Just r) = [r] - indexToReg Nothing = [] - indexToReg (Just (r,_)) = [r] - addrToRegs (ImmAddr _ _) = [] - - usage src dst = RU (mkUniqSet (filter interesting src)) - (mkUniqSet (filter interesting dst)) - - interesting (FixedReg _) = False - interesting _ = True - -freeRegs :: [Reg] -freeRegs = freeMappedRegs (\ x -> x) [0..15] - -freeMappedRegs :: (Int -> Int) -> [Int] -> [Reg] - -freeMappedRegs modify nums - = foldr free [] nums - where - free n acc - = let - modified_i = case (modify n) of { IBOX(x) -> x } - in - if _IS_TRUE_(freeReg modified_i) then (MappedReg modified_i) : acc else acc - -freeSet :: UniqSet Reg -freeSet = mkUniqSet freeRegs - -noUsage :: RegUsage -noUsage = RU emptyUniqSet emptyUniqSet - -endUsage :: RegUsage -endUsage = RU emptyUniqSet freeSet - -\end{code} - -@i386RegLiveness@ takes future liveness information and modifies it according to -the semantics of branches and labels. (An out-of-line branch clobbers the liveness -passed back by the following instruction; a forward local branch passes back the -liveness from the target label; a conditional branch merges the liveness from the -target and the liveness from its successor; a label stashes away the current liveness -in the future liveness environment). - -\begin{code} -i386RegLiveness :: I386Instr -> RegLiveness -> RegLiveness -i386RegLiveness instr info@(RL live future@(FL all env)) = case instr of - - JXX _ lbl -> RL (lookup lbl `unionUniqSets` live) future - JMP _ -> RL emptyUniqSet future - CALL _ -> RL live future - LABEL lbl -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live)) - _ -> info - - where - lookup lbl = case lookupFM env lbl of - Just regs -> regs - Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++ - " in future?") emptyUniqSet - -\end{code} - -@i386PatchRegs@ takes an instruction (possibly with MemoryReg/UnmappedReg registers) and -changes all register references according to the supplied environment. - -\begin{code} - -i386PatchRegs :: I386Instr -> (Reg -> Reg) -> I386Instr -i386PatchRegs instr env = case instr of - MOV sz src dst -> patch2 (MOV sz) src dst - MOVZX sz src dst -> patch2 (MOVZX sz) src dst - MOVSX sz src dst -> patch2 (MOVSX sz) src dst - LEA sz src dst -> patch2 (LEA sz) src dst - 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 - 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 - NOT sz op -> patch1 (NOT sz) op - NEGI sz op -> patch1 (NEGI sz) op - SHL sz imm dst -> patch1 (SHL sz imm) dst - SAR sz imm dst -> patch1 (SAR sz imm) dst - SHR sz imm dst -> patch1 (SHR sz imm) dst - TEST sz src dst -> patch2 (TEST sz) src dst - CMP sz src dst -> patch2 (CMP sz) src dst - PUSH sz op -> patch1 (PUSH sz) op - POP sz op -> patch1 (POP sz) op - SETCC cond op -> patch1 (SETCC cond) op - JMP op -> patch1 JMP op - FADD sz src -> FADD sz (patchOp src) - FIADD sz asrc -> FIADD sz (lookupAddr asrc) - FCOM sz src -> patch1 (FCOM sz) src - FDIV sz src -> FDIV sz (patchOp src) - --FDIVP sz src -> FDIVP sz (patchOp src) - FIDIV sz asrc -> FIDIV sz (lookupAddr asrc) - FDIVR sz src -> FDIVR sz (patchOp src) - --FDIVRP sz src -> FDIVRP sz (patchOp src) - FIDIVR sz asrc -> FIDIVR sz (lookupAddr asrc) - FICOM sz asrc -> FICOM sz (lookupAddr asrc) - FILD sz asrc dst -> FILD sz (lookupAddr asrc) (env dst) - FIST sz adst -> FIST sz (lookupAddr adst) - FLD sz src -> patch1 (FLD sz) (patchOp src) - FMUL sz src -> FMUL sz (patchOp src) - --FMULP sz src -> FMULP sz (patchOp src) - FIMUL sz asrc -> FIMUL sz (lookupAddr asrc) - FST sz dst -> FST sz (patchOp dst) - FSTP sz dst -> FSTP sz (patchOp dst) - FSUB sz src -> FSUB sz (patchOp src) - --FSUBP sz src -> FSUBP sz (patchOp src) - FISUB sz asrc -> FISUB sz (lookupAddr asrc) - FSUBR sz src -> FSUBR sz (patchOp src) - --FSUBRP sz src -> FSUBRP sz (patchOp src) - 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 (OpReg reg) = OpReg (env reg) - patchOp (OpImm imm) = OpImm imm - patchOp (OpAddr ea) = OpAddr (lookupAddr ea) - - 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) - = ImmAddr imm off - -\end{code} - -Sometimes, we want to be able to modify addresses at compile time. -(Okay, just for chrCode of a fetch.) - -\begin{code} -{-# SPECIALIZE - is13Bits :: Int -> Bool - #-} -{-# SPECIALIZE - is13Bits :: Integer -> Bool - #-} - -is13Bits :: Integral a => a -> Bool -is13Bits x = x >= -4096 && x < 4096 - -offset :: Addr -> Int -> Maybe Addr -offset (Addr reg index (ImmInt n)) off - = Just (Addr reg index (ImmInt n2)) - where n2 = n + off - -offset (Addr reg index (ImmInteger n)) off - = Just (Addr reg index (ImmInt (fromInteger n2))) - where n2 = n + toInteger off - -offset (ImmAddr imm off1) off2 - = Just (ImmAddr imm off3) - where off3 = off1 + off2 - -offset _ _ = Nothing -\end{code} - -If you value your sanity, do not venture below this line. - -\begin{code} - --- platform.h is generate and tells us what the target architecture is -#include "../../includes/platform.h" -#define STOLEN_X86_REGS 5 -#include "../../includes/MachRegs.h" -#include "../../includes/i386-unknown-linuxaout.h" - --- Redefine the literals used for I386 register names in the header --- files. Gag me with a spoon, eh? - -#define eax 0 -#define ebx 1 -#define ecx 2 -#define edx 3 -#define esi 4 -#define edi 5 -#define ebp 6 -#define esp 7 -#define st0 8 -#define st1 9 -#define st2 10 -#define st3 11 -#define st4 12 -#define st5 13 -#define st6 14 -#define st7 15 -#define CALLER_SAVES_Hp --- ToDo: rm when we give esp back -#define REG_Hp esp -#define REG_R2 ecx - -baseRegOffset :: MagicId -> Int -baseRegOffset StkOReg = OFFSET_StkO -baseRegOffset (VanillaReg _ ILIT2(1)) = OFFSET_R1 -baseRegOffset (VanillaReg _ ILIT2(2)) = OFFSET_R2 -baseRegOffset (VanillaReg _ ILIT2(3)) = OFFSET_R3 -baseRegOffset (VanillaReg _ ILIT2(4)) = OFFSET_R4 -baseRegOffset (VanillaReg _ ILIT2(5)) = OFFSET_R5 -baseRegOffset (VanillaReg _ ILIT2(6)) = OFFSET_R6 -baseRegOffset (VanillaReg _ ILIT2(7)) = OFFSET_R7 -baseRegOffset (VanillaReg _ ILIT2(8)) = OFFSET_R8 -baseRegOffset (FloatReg ILIT2(1)) = OFFSET_Flt1 -baseRegOffset (FloatReg ILIT2(2)) = OFFSET_Flt2 -baseRegOffset (FloatReg ILIT2(3)) = OFFSET_Flt3 -baseRegOffset (FloatReg ILIT2(4)) = OFFSET_Flt4 -baseRegOffset (DoubleReg ILIT2(1)) = OFFSET_Dbl1 -baseRegOffset (DoubleReg ILIT2(2)) = OFFSET_Dbl2 -baseRegOffset TagReg = OFFSET_Tag -baseRegOffset RetReg = OFFSET_Ret -baseRegOffset SpA = OFFSET_SpA -baseRegOffset SuA = OFFSET_SuA -baseRegOffset SpB = OFFSET_SpB -baseRegOffset SuB = OFFSET_SuB -baseRegOffset Hp = OFFSET_Hp -baseRegOffset HpLim = OFFSET_HpLim -baseRegOffset LivenessReg = OFFSET_Liveness ---baseRegOffset ActivityReg = OFFSET_Activity -#ifdef DEBUG -baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" -baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg" -baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg" -baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre" -baseRegOffset VoidReg = panic "baseRegOffset:VoidReg" -#endif - -callerSaves :: MagicId -> Bool -#ifdef CALLER_SAVES_Base -callerSaves BaseReg = True -#endif -#ifdef CALLER_SAVES_StkO -callerSaves StkOReg = True -#endif -#ifdef CALLER_SAVES_R1 -callerSaves (VanillaReg _ ILIT2(1)) = True -#endif -#ifdef CALLER_SAVES_R2 -callerSaves (VanillaReg _ ILIT2(2)) = True -#endif -#ifdef CALLER_SAVES_R3 -callerSaves (VanillaReg _ ILIT2(3)) = True -#endif -#ifdef CALLER_SAVES_R4 -callerSaves (VanillaReg _ ILIT2(4)) = True -#endif -#ifdef CALLER_SAVES_R5 -callerSaves (VanillaReg _ ILIT2(5)) = True -#endif -#ifdef CALLER_SAVES_R6 -callerSaves (VanillaReg _ ILIT2(6)) = True -#endif -#ifdef CALLER_SAVES_R7 -callerSaves (VanillaReg _ ILIT2(7)) = True -#endif -#ifdef CALLER_SAVES_R8 -callerSaves (VanillaReg _ ILIT2(8)) = True -#endif -#ifdef CALLER_SAVES_FltReg1 -callerSaves (FloatReg ILIT2(1)) = True -#endif -#ifdef CALLER_SAVES_FltReg2 -callerSaves (FloatReg ILIT2(2)) = True -#endif -#ifdef CALLER_SAVES_FltReg3 -callerSaves (FloatReg ILIT2(3)) = True -#endif -#ifdef CALLER_SAVES_FltReg4 -callerSaves (FloatReg ILIT2(4)) = True -#endif -#ifdef CALLER_SAVES_DblReg1 -callerSaves (DoubleReg ILIT2(1)) = True -#endif -#ifdef CALLER_SAVES_DblReg2 -callerSaves (DoubleReg ILIT2(2)) = True -#endif -#ifdef CALLER_SAVES_Tag -callerSaves TagReg = True -#endif -#ifdef CALLER_SAVES_Ret -callerSaves RetReg = True -#endif -#ifdef CALLER_SAVES_SpA -callerSaves SpA = True -#endif -#ifdef CALLER_SAVES_SuA -callerSaves SuA = True -#endif -#ifdef CALLER_SAVES_SpB -callerSaves SpB = True -#endif -#ifdef CALLER_SAVES_SuB -callerSaves SuB = True -#endif -#ifdef CALLER_SAVES_Hp -callerSaves Hp = True -#endif -#ifdef CALLER_SAVES_HpLim -callerSaves HpLim = True -#endif -#ifdef CALLER_SAVES_Liveness -callerSaves LivenessReg = True -#endif -#ifdef CALLER_SAVES_Activity ---callerSaves ActivityReg = True -#endif -#ifdef CALLER_SAVES_StdUpdRetVec -callerSaves StdUpdRetVecReg = True -#endif -#ifdef CALLER_SAVES_StkStub -callerSaves StkStubReg = True -#endif -callerSaves _ = False - -stgRegMap :: MagicId -> Maybe Reg - -#ifdef REG_Base -stgRegMap BaseReg = Just (FixedReg ILIT(REG_Base)) -#endif -#ifdef REG_StkO -stgRegMap StkOReg = Just (FixedReg ILIT(REG_StkOReg)) -#endif -#ifdef REG_R1 -stgRegMap (VanillaReg _ ILIT2(1)) = Just (FixedReg ILIT(REG_R1)) -#endif -#ifdef REG_R2 -stgRegMap (VanillaReg _ ILIT2(2)) = Just (FixedReg ILIT(REG_R2)) -#endif -#ifdef REG_R3 -stgRegMap (VanillaReg _ ILIT2(3)) = Just (FixedReg ILIT(REG_R3)) -#endif -#ifdef REG_R4 -stgRegMap (VanillaReg _ ILIT2(4)) = Just (FixedReg ILIT(REG_R4)) -#endif -#ifdef REG_R5 -stgRegMap (VanillaReg _ ILIT2(5)) = Just (FixedReg ILIT(REG_R5)) -#endif -#ifdef REG_R6 -stgRegMap (VanillaReg _ ILIT2(6)) = Just (FixedReg ILIT(REG_R6)) -#endif -#ifdef REG_R7 -stgRegMap (VanillaReg _ ILIT2(7)) = Just (FixedReg ILIT(REG_R7)) -#endif -#ifdef REG_R8 -stgRegMap (VanillaReg _ ILIT2(8)) = Just (FixedReg ILIT(REG_R8)) -#endif -#ifdef REG_Flt1 -stgRegMap (FloatReg ILIT2(1)) = Just (FixedReg ILIT(REG_Flt1)) -#endif -#ifdef REG_Flt2 -stgRegMap (FloatReg ILIT2(2)) = Just (FixedReg ILIT(REG_Flt2)) -#endif -#ifdef REG_Flt3 -stgRegMap (FloatReg ILIT2(3)) = Just (FixedReg ILIT(REG_Flt3)) -#endif -#ifdef REG_Flt4 -stgRegMap (FloatReg ILIT2(4)) = Just (FixedReg ILIT(REG_Flt4)) -#endif -#ifdef REG_Dbl1 -stgRegMap (DoubleReg ILIT2(1)) = Just (FixedReg ILIT(REG_Dbl1)) -#endif -#ifdef REG_Dbl2 -stgRegMap (DoubleReg ILIT2(2)) = Just (FixedReg ILIT(REG_Dbl2)) -#endif -#ifdef REG_Tag -stgRegMap TagReg = Just (FixedReg ILIT(REG_TagReg)) -#endif -#ifdef REG_Ret -stgRegMap RetReg = Just (FixedReg ILIT(REG_Ret)) -#endif -#ifdef REG_SpA -stgRegMap SpA = Just (FixedReg ILIT(REG_SpA)) -#endif -#ifdef REG_SuA -stgRegMap SuA = Just (FixedReg ILIT(REG_SuA)) -#endif -#ifdef REG_SpB -stgRegMap SpB = Just (FixedReg ILIT(REG_SpB)) -#endif -#ifdef REG_SuB -stgRegMap SuB = Just (FixedReg ILIT(REG_SuB)) -#endif -#ifdef REG_Hp -stgRegMap Hp = Just (FixedReg ILIT(REG_Hp)) -#endif -#ifdef REG_HpLim -stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim)) -#endif -#ifdef REG_Liveness -stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness)) -#endif -#ifdef REG_Activity ---stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity)) -#endif -#ifdef REG_StdUpdRetVec -stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec)) -#endif -#ifdef REG_StkStub -stgRegMap StkStubReg = Just (FixedReg ILIT(REG_StkStub)) -#endif - -stgRegMap _ = Nothing - -\end{code} - -Here is the list of registers we can use in register allocation. - -\begin{code} -freeReg :: FAST_INT -> FAST_BOOL - ---freeReg ILIT(esp) = _FALSE_ -- %esp is our stack pointer. - -#ifdef REG_Base -freeReg ILIT(REG_Base) = _FALSE_ -#endif -#ifdef REG_StkO -freeReg ILIT(REG_StkO) = _FALSE_ -#endif -#ifdef REG_R1 -freeReg ILIT(REG_R1) = _FALSE_ -#endif -#ifdef REG_R2 -freeReg ILIT(REG_R2) = _FALSE_ -#endif -#ifdef REG_R3 -freeReg ILIT(REG_R3) = _FALSE_ -#endif -#ifdef REG_R4 -freeReg ILIT(REG_R4) = _FALSE_ -#endif -#ifdef REG_R5 -freeReg ILIT(REG_R5) = _FALSE_ -#endif -#ifdef REG_R6 -freeReg ILIT(REG_R6) = _FALSE_ -#endif -#ifdef REG_R7 -freeReg ILIT(REG_R7) = _FALSE_ -#endif -#ifdef REG_R8 -freeReg ILIT(REG_R8) = _FALSE_ -#endif -#ifdef REG_Flt1 -freeReg ILIT(REG_Flt1) = _FALSE_ -#endif -#ifdef REG_Flt2 -freeReg ILIT(REG_Flt2) = _FALSE_ -#endif -#ifdef REG_Flt3 -freeReg ILIT(REG_Flt3) = _FALSE_ -#endif -#ifdef REG_Flt4 -freeReg ILIT(REG_Flt4) = _FALSE_ -#endif -#ifdef REG_Dbl1 -freeReg ILIT(REG_Dbl1) = _FALSE_ -#endif -#ifdef REG_Dbl2 -freeReg ILIT(REG_Dbl2) = _FALSE_ -#endif -#ifdef REG_Tag -freeReg ILIT(REG_Tag) = _FALSE_ -#endif -#ifdef REG_Ret -freeReg ILIT(REG_Ret) = _FALSE_ -#endif -#ifdef REG_SpA -freeReg ILIT(REG_SpA) = _FALSE_ -#endif -#ifdef REG_SuA -freeReg ILIT(REG_SuA) = _FALSE_ -#endif -#ifdef REG_SpB -freeReg ILIT(REG_SpB) = _FALSE_ -#endif -#ifdef REG_SuB -freeReg ILIT(REG_SuB) = _FALSE_ -#endif -#ifdef REG_Hp -freeReg ILIT(REG_Hp) = _FALSE_ -#endif -#ifdef REG_HpLim -freeReg ILIT(REG_HpLim) = _FALSE_ -#endif -#ifdef REG_Liveness -freeReg ILIT(REG_Liveness) = _FALSE_ -#endif -#ifdef REG_Activity ---freeReg ILIT(REG_Activity) = _FALSE_ -#endif -#ifdef REG_StdUpdRetVec -freeReg ILIT(REG_StdUpdRetVec) = _FALSE_ -#endif -#ifdef REG_StkStub -freeReg ILIT(REG_StkStub) = _FALSE_ -#endif -freeReg n -#ifdef REG_Dbl1 - | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_ -#endif -#ifdef REG_Dbl2 - | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_ -#endif - - | otherwise = _TRUE_ - -reservedRegs :: [Int] -reservedRegs = [] ---reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2, --- NCG_Reserved_F1, NCG_Reserved_F2, --- NCG_Reserved_D1, NCG_Reserved_D2] - -\end{code} - diff --git a/ghc/compiler/nativeGen/I386Desc.lhs b/ghc/compiler/nativeGen/I386Desc.lhs deleted file mode 100644 index b7b3233..0000000 --- a/ghc/compiler/nativeGen/I386Desc.lhs +++ /dev/null @@ -1,198 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1995 -% -\section[I386Desc]{The I386 Machine Description} - -\begin{code} -#include "HsVersions.h" - -module I386Desc ( - mkI386 - - -- and assorted nonsense referenced by the class methods - ) where - -import AbsCSyn -import PrelInfo ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..), - RegLiveness(..), RegUsage(..), FutureLive(..) - ) -import CLabel ( CLabel ) -import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) ) -import HeapOffs ( hpRelToInt ) -import MachDesc -import Maybes ( Maybe(..) ) -import OrdList -import Outputable -import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) -import I386Code -import I386Gen ( i386CodeGen ) -import Stix -import StixMacro -import StixPrim -import UniqSupply -import Util -\end{code} - -Header sizes depend only on command-line options, not on the target -architecture. (I think.) - -\begin{code} - -fhs :: (GlobalSwitch -> SwitchResult) -> Int - -fhs switches = 1 + profFHS + ageFHS - where - profFHS = if switchIsOn switches SccProfilingOn then 1 else 0 - ageFHS = if switchIsOn switches SccProfilingOn then 1 else 0 - -vhs :: (GlobalSwitch -> SwitchResult) -> SMRep -> Int - -vhs switches sm = case sm of - StaticRep _ _ -> 0 - SpecialisedRep _ _ _ _ -> 0 - GenericRep _ _ _ -> 0 - BigTupleRep _ -> 1 - MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -} - DataRep _ -> 1 - DynamicRep -> 2 - BlackHoleRep -> 0 - PhantomRep -> panic "vhs:phantom" - -\end{code} - -Here we map STG registers onto appropriate Stix Trees. First, we -handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@. -The rest are either in real machine registers or stored as offsets -from BaseReg. - -\begin{code} - -i386Reg :: (GlobalSwitch -> SwitchResult) -> MagicId -> RegLoc - -i386Reg switches x = - case stgRegMap x of - Just reg -> Save nonReg - Nothing -> Always nonReg - where nonReg = case x of - StkStubReg -> sStLitLbl SLIT("STK_STUB_closure") - StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame") - BaseReg -> sStLitLbl SLIT("MainRegTable") - --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) - _ -> StInd (kindFromMagicId x) - (StPrim IntAddOp [baseLoc, StInt (toInteger (offset*4))]) - baseLoc = case stgRegMap BaseReg of - Just _ -> StReg (StixMagicId BaseReg) - Nothing -> sStLitLbl SLIT("MainRegTable") - offset = baseRegOffset x - -\end{code} - -Sizes in bytes. - -\begin{code} - -size pk = case kindToSize pk of - {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 } - -\end{code} - -Now the volatile saves and restores. We add the basic guys to the list of ``user'' -registers provided. Note that there are more basic registers on the restore list, -because some are reloaded from constants. - -\begin{code} - -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 - 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) - ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols)) - where - restore x = StAssign (kindFromMagicId x) reg loc - where reg = StReg (StixMagicId x) - loc = case i386Reg switches x of - Save loc -> loc - Always loc -> panic "vrests" - -\end{code} - -Static closure sizes. - -\begin{code} - -charLikeSize, intLikeSize :: Target -> Int - -charLikeSize target = - size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1) - where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm - -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 - words = fhs switches + vhs switches (MuTupleRep 0) - -dhs switches = StInt (toInteger words) - where - words = fhs switches + vhs switches (DataRep 0) - -\end{code} - -Setting up a i386 target. - -\begin{code} -mkI386 :: Bool - -> (GlobalSwitch -> SwitchResult) - -> (Target, - (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen - Bool, -- underscore - (String -> String)) -- fmtAsmLbl - -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 - csz = charLikeSize target - isz = intLikeSize target - mhs' = mhs switches - dhs' = dhs switches - ps = genPrimCode target - mc = genMacroCode target - hc = doHeapCheck - target = mkTarget {-switches-} fhs' vhs' i386Reg' {-id-} size - hprel as as' - (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc) - {-i386CodeGen decentOS id-} - in - (target, i386CodeGen, decentOS, id) -\end{code} - - - diff --git a/ghc/compiler/nativeGen/I386Gen.lhs b/ghc/compiler/nativeGen/I386Gen.lhs deleted file mode 100644 index 0edbba1..0000000 --- a/ghc/compiler/nativeGen/I386Gen.lhs +++ /dev/null @@ -1,1639 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1995 -% - -\begin{code} -#include "HsVersions.h" -#include "../includes/i386-unknown-linuxaout.h" - -module I386Gen ( - i386CodeGen, - - -- and, for self-sufficiency - PprStyle, StixTree, CSeq - ) where - -IMPORT_Trace - -import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId ) -import PrelInfo ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos, - Reg(..), RegLiveness(..), RegUsage(..), - FutureLive(..), MachineRegisters(..), MachineCode(..) - ) -import CLabel ( CLabel, isAsmTemp ) -import I386Code {- everything -} -import MachDesc -import Maybes ( maybeToBool, Maybe(..) ) -import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList ) -import Outputable -import I386Desc -import Stix -import UniqSupply -import Pretty -import Unpretty -import Util - -type CodeBlock a = (OrdList a -> OrdList a) -\end{code} - -%************************************************************************ -%* * -\subsection[I386CodeGen]{Generating I386 Code} -%* * -%************************************************************************ - -This is the top-level code-generation function for the I386. - -\begin{code} - -i386CodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty -i386CodeGen sty trees = - mapUs genI386Code trees `thenUs` \ dynamicCodes -> - let - staticCodes = scheduleI386Code dynamicCodes - pretty = printLabeledCodes sty staticCodes - in - returnUs pretty - -\end{code} - -This bit does the code scheduling. The scheduler must also deal with -register allocation of temporaries. Much parallelism can be exposed via -the OrdList, but more might occur, so further analysis might be needed. - -\begin{code} - -scheduleI386Code :: [I386Code] -> [I386Instr] -scheduleI386Code = concat . map (runRegAllocate freeI386Regs reservedRegs) - where - freeI386Regs :: I386Regs - freeI386Regs = mkMRegs (extractMappedRegNos freeRegs) - - -\end{code} - -Registers passed up the tree. If the stix code forces the register -to live in a pre-decided machine register, it comes out as @Fixed@; -otherwise, it comes out as @Any@, and the parent can decide which -register to put it in. - -\begin{code} - -data Register - = Fixed Reg PrimRep (CodeBlock I386Instr) - | Any PrimRep (Reg -> (CodeBlock I386Instr)) - -registerCode :: Register -> Reg -> CodeBlock I386Instr -registerCode (Fixed _ _ code) reg = code -registerCode (Any _ code) reg = code reg - -registerName :: Register -> Reg -> Reg -registerName (Fixed reg _ _) _ = reg -registerName (Any _ _) reg = reg - -registerKind :: Register -> PrimRep -registerKind (Fixed _ pk _) = pk -registerKind (Any pk _) = pk - -isFixed :: Register -> Bool -isFixed (Fixed _ _ _) = True -isFixed (Any _ _) = False - -\end{code} - -Memory addressing modes passed up the tree. - -\begin{code} - -data Amode = Amode Addr (CodeBlock I386Instr) - -amodeAddr (Amode addr _) = addr -amodeCode (Amode _ code) = code - -\end{code} - -Condition codes passed up the tree. - -\begin{code} - -data Condition = Condition Bool Cond (CodeBlock I386Instr) - -condName (Condition _ cond _) = cond -condFloat (Condition float _ _) = float -condCode (Condition _ _ code) = code - -\end{code} - -General things for putting together code sequences. - -\begin{code} - -asmVoid :: OrdList I386Instr -asmVoid = mkEmptyList - -asmInstr :: I386Instr -> I386Code -asmInstr i = mkUnitList i - -asmSeq :: [I386Instr] -> I386Code -asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is - -asmParThen :: [I386Code] -> (CodeBlock I386Instr) -asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code - -returnInstr :: I386Instr -> UniqSM (CodeBlock I386Instr) -returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs) - -returnInstrs :: [I386Instr] -> UniqSM (CodeBlock I386Instr) -returnInstrs instrs = returnUs (\xs -> 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 - -mkSeqInstrs :: [I386Instr] -> (CodeBlock I386Instr) -mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code - -\end{code} - -Top level i386 code generator for a chunk of stix code. - -\begin{code} - -genI386Code :: [StixTree] -> UniqSM (I386Code) - -genI386Code trees = - mapUs getCode trees `thenUs` \ blocks -> - returnUs (foldr (.) id blocks asmVoid) - -\end{code} - -Code extractor for an entire stix tree---stix statement level. - -\begin{code} - -getCode - :: StixTree -- a stix statement - -> UniqSM (CodeBlock I386Instr) - -getCode (StSegment seg) = returnInstr (SEGMENT seg) - -getCode (StAssign 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) = returnUs id - -getCode (StJump arg) = genJump arg - -getCode (StFallThrough lbl) = returnUs id - -getCode (StCondJump lbl arg) = genCondJump lbl arg - -getCode (StData kind args) = - mapAndUnzipUs getData args `thenUs` \ (codes, imms) -> - returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms)) - (foldr1 (.) codes xs)) - where - 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) - -\end{code} - -Generate code to get a subtree into a register. - -\begin{code} - -getReg :: StixTree -> UniqSM Register - -getReg (StReg (StixMagicId stgreg)) = - case stgRegMap stgreg of - Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id) - -- cannot be Nothing - -getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id) - -getReg (StDouble 0.0) - = let - code dst = mkSeqInstrs [FLDZ] - in - returnUs (Any DoubleRep code) - -getReg (StDouble 1.0) - = let - code dst = mkSeqInstrs [FLD1] - in - returnUs (Any DoubleRep code) - -getReg (StDouble d) = - getUniqLabelNCG `thenUs` \ lbl -> - --getNewRegNCG PtrRep `thenUs` \ tmp -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - DATA D [strImmLit ('0' : 'd' :ppShow 80 (ppRational d))], - SEGMENT TextSegment, - FLD D (OpImm (ImmCLbl lbl)) - ] - in - returnUs (Any DoubleRep code) - -getReg (StString s) = - getUniqLabelNCG `thenUs` \ lbl -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - ASCII True (_UNPK_ s), - SEGMENT TextSegment, - MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)] - in - returnUs (Any PtrRep code) - -getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' = - getUniqLabelNCG `thenUs` \ lbl -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - ASCII False (init xs), - SEGMENT TextSegment, - MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)] - in - returnUs (Any PtrRep code) - where - xs = _UNPK_ (_TAIL_ s) - - -getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree) - -getReg (StCall fn kind args) = - genCCall fn kind args `thenUs` \ call -> - returnUs (Fixed reg kind call) - where - reg = if isFloatingRep kind then st0 else eax - -getReg (StPrim primop args) = - case primop of - - CharGtOp -> condIntReg GT args - CharGeOp -> condIntReg GE args - CharEqOp -> condIntReg EQ args - CharNeOp -> condIntReg NE 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 - - IntSubOp -> subCode L args - IntMulOp -> trivialCode (IMUL L) args True - IntQuotOp -> divCode L args True -- division - 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 - SllOp -> trivialCode (SHL L) args False - SraOp -> trivialCode (SAR L) args False - SrlOp -> trivialCode (SHR L) args False - 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 - WordNeOp -> condIntReg NE args - WordLtOp -> condIntReg LU args - WordLeOp -> condIntReg LEU args - - AddrGtOp -> condIntReg GU args - AddrGeOp -> condIntReg GEU args - AddrEqOp -> condIntReg EQ args - AddrNeOp -> condIntReg NE args - AddrLtOp -> condIntReg LU args - AddrLeOp -> condIntReg LEU 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 - FloatEqOp -> condFltReg EQ args - FloatNeOp -> condFltReg NE args - FloatLtOp -> condFltReg LT args - FloatLeOp -> condFltReg LE 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 - DoubleNeOp -> condFltReg NE args - DoubleLtOp -> condFltReg LT args - DoubleLeOp -> condFltReg LE 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 FloatRep args - Double2IntOp -> coerceFP2Int args - Int2DoubleOp -> coerceInt2FP DoubleRep args - - Double2FloatOp -> coerceFltCode args - Float2DoubleOp -> coerceFltCode 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] - -getReg (StInd pk mem) = - getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - size = kindToSize pk - 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 - returnUs (Any pk code__2) - - -getReg (StInt i) - = let - src = ImmInt (fromInteger i) - code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst)) - in - returnUs (Any IntRep code) - -getReg leaf - | maybeToBool imm = - let - code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst)) - in - returnUs (Any PtrRep code) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - -\end{code} - -Now, given a tree (the argument to an StInd) that references memory, -produce a suitable addressing mode. - -\begin{code} - -getAmode :: StixTree -> UniqSM Amode - -getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) - -getAmode (StPrim IntSubOp [x, StInt i]) - = - getNewRegNCG PtrRep `thenUs` \ tmp -> - getReg x `thenUs` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (-(fromInteger i)) - in - returnUs (Amode (Addr (Just reg) Nothing off) code) - -getAmode (StPrim IntAddOp [x, StInt i]) - | maybeToBool imm - = let - code = mkSeqInstrs [] - in - 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 PtrRep `thenUs` \ tmp -> - getReg x `thenUs` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (fromInteger i) - in - returnUs (Amode (Addr (Just reg) Nothing off) code) - -getAmode (StPrim IntAddOp [x, y]) = - 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 - code2 = registerCode register2 tmp2 asmVoid - reg2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] - in - returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) - -getAmode leaf - | maybeToBool imm = - let code = mkSeqInstrs [] - in - returnUs (Amode (ImmAddr imm__2 0) code) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - -getAmode other = - getNewRegNCG PtrRep `thenUs` \ tmp -> - getReg other `thenUs` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = Nothing - in - returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code) - -\end{code} - -\begin{code} -getOp - :: StixTree - -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size -getOp (StInt i) - = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L) - -getOp (StInd pk mem) - = getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode --asmVoid - addr = amodeAddr amode - sz = kindToSize pk - in returnUs (code, OpAddr addr, sz) - -getOp op - = getReg op `thenUs` \ register -> - getNewRegNCG (registerKind register) - `thenUs` \ tmp -> - let - code = registerCode register tmp - reg = registerName register tmp - pk = registerKind register - sz = kindToSize pk - in - returnUs (code, OpReg reg, sz) - -getOpRI - :: StixTree - -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size -getOpRI op - | maybeToBool imm - = returnUs (asmParThen [], OpImm imm_op, L) - where - imm = maybeImm op - imm_op = case imm of Just x -> x - -getOpRI op - = getReg op `thenUs` \ register -> - getNewRegNCG (registerKind register) - `thenUs` \ tmp -> - let - code = registerCode register tmp - reg = registerName register tmp - pk = registerKind register - sz = kindToSize pk - in - returnUs (code, OpReg reg, sz) - -\end{code} - -Set up a condition code for a conditional branch. - -\begin{code} - -getCondition :: StixTree -> UniqSM Condition - -getCondition (StPrim primop args) = - case primop of - - CharGtOp -> condIntCode GT args - CharGeOp -> condIntCode GE args - CharEqOp -> condIntCode EQ args - CharNeOp -> condIntCode NE args - CharLtOp -> condIntCode LT args - CharLeOp -> condIntCode LE args - - IntGtOp -> condIntCode GT args - IntGeOp -> condIntCode GE args - IntEqOp -> condIntCode EQ 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 - WordNeOp -> condIntCode NE args - WordLtOp -> condIntCode LU args - WordLeOp -> condIntCode LEU args - - AddrGtOp -> condIntCode GU args - AddrGeOp -> condIntCode GEU args - AddrEqOp -> condIntCode EQ args - AddrNeOp -> condIntCode NE args - AddrLtOp -> condIntCode LU args - AddrLeOp -> condIntCode LEU args - - FloatGtOp -> condFltCode GT args - FloatGeOp -> condFltCode GE args - FloatEqOp -> condFltCode EQ args - FloatNeOp -> condFltCode NE args - FloatLtOp -> condFltCode LT args - FloatLeOp -> condFltCode LE args - - DoubleGtOp -> condFltCode GT args - DoubleGeOp -> condFltCode GE args - DoubleEqOp -> condFltCode EQ args - DoubleNeOp -> condFltCode NE args - DoubleLtOp -> condFltCode LT args - DoubleLeOp -> condFltCode LE args - -\end{code} - -Turn a boolean expression into a condition, to be passed -back up the tree. - -\begin{code} - -condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition -condIntCode cond [StInd _ x, y] - | maybeToBool imm - = getAmode x `thenUs` \ amode -> - let - code1 = amodeCode amode asmVoid - y__2 = amodeAddr amode - code__2 = asmParThen [code1] . - mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2)) - in - 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 `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code__2 = asmParThen [code1] . - mkSeqInstr (TEST L (OpReg src1) (OpReg src1)) - in - returnUs (Condition False cond code__2) - -condIntCode cond [x, y] - | maybeToBool imm - = getReg x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code__2 = asmParThen [code1] . - mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1)) - in - 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 `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] . - mkSeqInstr (CMP L (OpReg src2) (OpAddr src1)) - in - returnUs (Condition False cond code__2) - -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] . - mkSeqInstr (CMP L (OpAddr src1) (OpReg src2)) - in - returnUs (Condition False cond code__2) - -condIntCode cond [x, y] = - 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] . - mkSeqInstr (CMP L (OpReg src2) (OpReg src1)) - in - returnUs (Condition False cond code__2) - -condFltCode cond [x, StDouble 0.0] = - getReg x `thenUs` \ register1 -> - getNewRegNCG (registerKind register1) - `thenUs` \ tmp1 -> - let - pk1 = registerKind register1 - code1 = registerCode register1 tmp1 - src1 = registerName 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 - ] - in - returnUs (Condition True (fixFPCond cond) code__2) - -condFltCode cond [x, y] = - getReg x `thenUs` \ register1 -> - getReg y `thenUs` \ register2 -> - getNewRegNCG (registerKind register1) - `thenUs` \ tmp1 -> - getNewRegNCG (registerKind register2) - `thenUs` \ tmp2 -> - let - pk1 = registerKind register1 - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - code2 = registerCode register2 tmp2 - src2 = registerName register2 tmp2 - - 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 - ] - in - returnUs (Condition True (fixFPCond cond) code__2) - -\end{code} - -Turn those condition codes into integers now (when they appear on -the right hand side of an assignment). - -\begin{code} - -condIntReg :: Cond -> [StixTree] -> UniqSM Register -condIntReg cond args = - 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 --- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move. - code__2 dst = code . mkSeqInstrs [ - SETCC cond (OpReg tmp), - AND L (OpImm (ImmInt 1)) (OpReg tmp), - MOV L (OpReg tmp) (OpReg dst)] - in - returnUs (Any IntRep code__2) - -condFltReg :: Cond -> [StixTree] -> UniqSM Register - -condFltReg cond args = - 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, - MOV L (OpImm (ImmInt 0)) (OpReg dst), - JXX ALWAYS lbl2, - LABEL lbl1, - MOV L (OpImm (ImmInt 1)) (OpReg dst), - LABEL lbl2] - in - returnUs (Any IntRep code__2) - -\end{code} - -Assignments are really at the heart of the whole code generation business. -Almost all top-level nodes of any real importance are assignments, which -correspond to loads, stores, or register transfers. If we're really lucky, -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). - -\begin{code} - -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)) - in - returnUs code__2 - -assignIntCode pk dst (StInd _ src) = - 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)) - in - returnUs code__2 - -assignIntCode pk dst src = - 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 - in - 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 - addrdst1 = amodeAddr amodedst - addrsrc2 = case (offset addrsrc1 4) of Just x -> x - addrdst2 = case (offset addrdst1 4) of Just x -> x - - code__2 = asmParThen [codesrc1, codedst1] . - mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp), - MOV L (OpReg tmp) (OpAddr addrdst1)] - ++ - if pk == DoubleRep - then [MOV L (OpAddr addrsrc2) (OpReg tmp), - MOV L (OpReg tmp) (OpAddr addrdst2)] - else []) - in - returnUs code__2 - -assignFltCode pk (StInd _ dst) src = - --getNewRegNCG pk `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getReg src `thenUs` \ register -> - let - sz = kindToSize pk - dst__2 = amodeAddr amode - - code1 = amodeCode amode asmVoid - code2 = registerCode register {-tmp-}st0 asmVoid - - --src__2 = registerName register tmp - pk__2 = registerKind register - sz__2 = kindToSize pk__2 - - code__2 = asmParThen [code1, code2] . - mkSeqInstr (FSTP sz (OpAddr dst__2)) - in - returnUs code__2 - -assignFltCode pk dst src = - getReg dst `thenUs` \ register1 -> - getReg src `thenUs` \ register2 -> - --getNewRegNCG (registerKind register2) - -- `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 - in - returnUs code__2 - -\end{code} - -Generating an unconditional branch. We accept two types of targets: -an immediate CLabel or a tree that gets evaluated into a register. -Any CLabels which are AsmTemporaries are assumed to be in the local -block of code, close enough for a branch instruction. Other CLabels -are assumed to be far away, so we use call. - -Do not fill the delay slots here; you will confuse the register allocator. - -\begin{code} - -genJump - :: StixTree -- the branch target - -> UniqSM (CodeBlock I386Instr) - -{- -genJump (StCLbl lbl) - | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl] - | otherwise = returnInstrs [JMP (OpImm target)] - where - target = ImmCLbl lbl --} - -genJump (StInd pk mem) = - getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode - target = amodeAddr amode - in - returnSeq code [JMP (OpAddr target)] - -genJump tree - | maybeToBool imm - = returnInstr (JMP (OpImm target)) - where - imm = maybeImm tree - target = case imm of Just x -> x - - -genJump tree = - getReg tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> - let - code = registerCode register tmp - target = registerName register tmp - in - returnSeq code [JMP (OpReg target)] - -\end{code} - -Conditional jumps are always to local labels, so we can use -branch instructions. First, we have to ensure that the condition -codes are set according to the supplied comparison operation. - -\begin{code} - -genCondJump - :: CLabel -- the branch target - -> StixTree -- the condition on which to branch - -> UniqSM (CodeBlock I386Instr) - -genCondJump lbl bool = - getCondition bool `thenUs` \ condition -> - let - code = condCode condition - cond = condName condition - target = ImmCLbl lbl - in - returnSeq code [JXX cond lbl] - -\end{code} - -\begin{code} - -genCCall - :: FAST_STRING -- function to call - -> PrimRep -- type of the result - -> [StixTree] -- arguments (of mixed type) - -> UniqSM (CodeBlock I386Instr) - -genCCall fn kind [StInt i] - | fn == SLIT ("PerformGC_wrapper") - = 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] - in - returnInstrs call - -genCCall fn kind args = - 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) - ] - in - returnSeq (code1 . code2) call - where - -- function names that begin with '.' are assumed to be special internally - -- generated names like '.mul,' which don't get an underscore prefix - fn__2 = case (_HEAD_ fn) of - '.' -> uppPStr fn - _ -> uppBeside (uppChar '_') (uppPStr fn) - - 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 -side, because that's where the generic optimizer will have put them. - -\begin{code} - -trivialCode - :: (Operand -> Operand -> I386Instr) - -> [StixTree] - -> Bool -- is the instr commutative? - -> UniqSM Register - -trivialCode instr [x, y] _ - | maybeToBool imm - = getReg x `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 - mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)] - in - 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 `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)) - in - 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 `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)) - in - returnUs (Any pk code__2) - -trivialCode instr [StInd pk mem, y] _ - = 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 - 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 - returnUs (Any pk code__2) - -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 - src2 = registerName register2 tmp2 - 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 - returnUs (Any IntRep code__2) - -addCode - :: Size - -> [StixTree] - -> UniqSM Register -addCode sz [x, StInt y] - = - 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)) - in - returnUs (Any IntRep code__2) - -addCode sz [x, StInd _ mem] - = getReg x `thenUs` \ register1 -> - --getNewRegNCG (registerKind register1) - -- `thenUs` \ tmp1 -> - getAmode mem `thenUs` \ amode -> - let - code2 = amodeCode amode - src2 = amodeAddr amode - - fixedname = registerName register1 eax - 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)] - in - returnUs (Any IntRep code__2) - -addCode sz [StInd _ mem, y] - = getReg y `thenUs` \ register2 -> - --getNewRegNCG (registerKind register2) - -- `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)] - in - returnUs (Any IntRep code__2) - -addCode sz [x, y] = - 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)) - in - returnUs (Any IntRep code__2) - -subCode - :: Size - -> [StixTree] - -> UniqSM Register -subCode sz [x, StInt y] - = 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)) - in - returnUs (Any IntRep code__2) - -subCode sz args = trivialCode (SUB sz) args False - -divCode - :: Size - -> [StixTree] - -> Bool -- True => division, False => remainder operation - -> UniqSM Register - --- 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 `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)] - in - returnUs (Fixed (if is_division then eax else edx) IntRep code__2) - -divCode sz [x, StInt i] is_division - = 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)))] - in - returnUs (Fixed (if is_division then eax else edx) IntRep code__2) - -divCode sz [x, y] is_division - = 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)))] - in - returnUs (Fixed (if is_division then eax else edx) IntRep code__2) - -trivialFCode - :: PrimRep - -> (Size -> Operand -> I386Instr) - -> (Size -> Operand -> I386Instr) -- reversed instr - -> I386Instr -- pop - -> I386Instr -- reversed instr, pop - -> [StixTree] - -> UniqSM Register -trivialFCode pk _ instrr _ _ [StInd pk' mem, y] - = getReg y `thenUs` \ register2 -> - --getNewRegNCG (registerKind register2) - -- `thenUs` \ tmp2 -> - getAmode mem `thenUs` \ amode -> - let - code1 = amodeCode amode - src1 = amodeAddr amode - - code__2 dst = let - code2 = registerCode register2 dst - src2 = registerName register2 dst - in asmParThen [code1 asmVoid,code2 asmVoid] . - mkSeqInstrs [instrr (kindToSize pk) (OpAddr src1)] - in - returnUs (Any pk code__2) - -trivialFCode pk instr _ _ _ [x, StInd pk' mem] - = getReg x `thenUs` \ register1 -> - --getNewRegNCG (registerKind register1) - -- `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] . - mkSeqInstrs [instr (kindToSize pk) (OpAddr src2)] - in - returnUs (Any pk code__2) - -trivialFCode pk _ _ _ instrpr [x, y] = - getReg x `thenUs` \ register1 -> - getReg y `thenUs` \ register2 -> - --getNewRegNCG (registerKind register1) - -- `thenUs` \ tmp1 -> - --getNewRegNCG (registerKind register2) - -- `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - let - pk1 = registerKind register1 - code1 = registerCode register1 st0 --tmp1 - src1 = registerName register1 st0 --tmp1 - - pk2 = registerKind register2 - - code__2 dst = let - code2 = registerCode register2 dst - src2 = registerName register2 dst - in asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr instrpr - in - returnUs (Any pk1 code__2) - -\end{code} - -Trivial unary instructions. Note that we don't have to worry about -matching an StInt as the argument, because genericOpt will already -have handled the constant-folding. - -\begin{code} - -trivialUCode - :: (Operand -> I386Instr) - -> [StixTree] - -> UniqSM Register - -trivialUCode instr [x] = - 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)) - in - returnUs (Any IntRep code__2) - -trivialUFCode - :: PrimRep - -> I386Instr - -> [StixTree] - -> UniqSM Register - -trivialUFCode pk instr [StInd pk' mem] = - getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - code__2 dst = code . mkSeqInstrs [FLD (kindToSize pk) (OpAddr src), - instr] - in - returnUs (Any pk code__2) - -trivialUFCode pk instr [x] = - 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 - returnUs (Any pk code__2) -\end{code} - -Absolute value on integers, mostly for gmp size check macros. Again, -the argument cannot be an StInt, because genericOpt already folded -constants. - -\begin{code} - -absIntCode :: [StixTree] -> UniqSM Register -absIntCode [x] = - 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 - 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 :: PrimRep -> [StixTree] -> UniqSM Register -coerceIntCode pk [x] = - getReg x `thenUs` \ register -> - case register of - Fixed reg _ code -> returnUs (Fixed reg pk code) - Any _ code -> returnUs (Any pk code) - -coerceFltCode :: [StixTree] -> UniqSM Register -coerceFltCode [x] = - getReg x `thenUs` \ register -> - case register of - Fixed reg _ code -> returnUs (Fixed reg DoubleRep code) - Any _ code -> returnUs (Any DoubleRep code) - -\end{code} - -Integer to character conversion. We try to do this in one step if -the original object is in memory. - -\begin{code} -chrCode :: [StixTree] -> UniqSM Register -{- -chrCode [StInd pk mem] = - getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - code__2 dst = code . mkSeqInstr (MOVZX L (OpAddr src) (OpReg dst)) - in - returnUs (Any pk code__2) --} -chrCode [x] = - 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 - returnUs (Any IntRep code__2) - -\end{code} - -More complicated integer/float conversions. Here we have to store -temporaries in memory to move between the integer and the floating -point register sets. - -\begin{code} -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 - MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), - FILD (kindToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] - in - returnUs (Any pk code__2) - -coerceFP2Int :: [StixTree] -> UniqSM Register -coerceFP2Int [x] = - 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 [ - FRNDINT, - FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)), - MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] - in - returnUs (Any IntRep code__2) -\end{code} - -Some random little helpers. - -\begin{code} - -maybeImm :: StixTree -> Maybe Imm -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)) -maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s))) -maybeImm (StCLbl l) = Just (ImmCLbl l) -maybeImm _ = Nothing - -mangleIndexTree :: StixTree -> StixTree - -mangleIndexTree (StIndex pk base (StInt i)) = - StPrim IntAddOp [base, off] - where - off = StInt (i * size pk) - size :: PrimRep -> Integer - size pk = case kindToSize pk of - {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 } - -mangleIndexTree (StIndex pk base off) = - case pk of - CharRep -> StPrim IntAddOp [base, off] - _ -> StPrim IntAddOp [base, off__2] - where - off__2 = StPrim SllOp [off, StInt (shift pk)] - shift :: PrimRep -> Integer - shift DoubleRep = 3 - shift _ = 2 - -cvtLitLit :: String -> String -cvtLitLit "stdin" = "_IO_stdin_" -cvtLitLit "stdout" = "_IO_stdout_" -cvtLitLit "stderr" = "_IO_stderr_" -cvtLitLit s - | isHex s = s - | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''") - where - isHex ('0':'x':xs) = all isHexDigit xs - isHex _ = False - -- Now, where have I seen this before? - isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' - - -\end{code} - -\begin{code} - -stackArgLoc = 23 :: Int -- where to stack call arguments - -\end{code} - -\begin{code} - -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! -fixFPCond GE = GEU -fixFPCond GT = GU -fixFPCond LT = LU -fixFPCond LE = LEU -fixFPCond any = any -\end{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs new file mode 100644 index 0000000..25d9be3 --- /dev/null +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -0,0 +1,3248 @@ +% +% (c) The AQUA Project, Glasgow University, 1996 +% +\section[MachCode]{Generating machine code} + +This is a big module, but, if you pay attention to +(a) the sectioning, (b) the type signatures, and +(c) the \tr{#if blah_TARGET_ARCH} things, the +structure should not be too overwhelming. + +\begin{code} +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where + +import Ubiq{-uitious-} + +import MachMisc -- may differ per-platform +import MachRegs + +import AbsCSyn ( MagicId ) +import AbsCUtils ( magicIdPrimRep ) +import CLabel ( isAsmTemp ) +import Maybes ( maybeToBool, expectJust ) +import OrdList -- quite a bit of it +import Pretty ( prettyToUn, ppRational ) +import PrimRep ( isFloatingRep, PrimRep(..) ) +import PrimOp ( PrimOp(..) ) +import Stix ( getUniqLabelNCG, StixTree(..), + StixReg(..), CodeSegment(..) + ) +import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, + mapAccumLUs, UniqSM(..) + ) +import Unpretty ( uppPStr ) +import Util ( panic, assertPanic ) +\end{code} + +Code extractor for an entire stix tree---stix statement level. + +\begin{code} +stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock + +stmt2Instrs stmt = case stmt of + StComment s -> returnInstr (COMMENT s) + StSegment seg -> returnInstr (SEGMENT seg) + StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab)) + StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id) + StLabel lab -> returnInstr (LABEL lab) + + StJump arg -> genJump arg + StCondJump lab arg -> genCondJump lab arg + StCall fn VoidRep args -> genCCall fn VoidRep args + + StAssign pk dst src + | isFloatingRep pk -> assignFltCode pk dst src + | otherwise -> assignIntCode pk dst src + + StFallThrough lbl + -- When falling through on the Alpha, we still have to load pv + -- with the address of the next routine, so that it can load gp. + -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl))) + ,returnUs id) + + StData kind args + -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) -> + returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms)) + (foldr1 (.) codes xs)) + where + getData :: StixTree -> UniqSM (InstrBlock, Imm) + + getData (StInt i) = returnUs (id, ImmInteger i) + getData (StDouble d) = returnUs (id, dblImmLit d) + getData (StLitLbl s) = returnUs (id, ImmLab s) + getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s))) + getData (StCLbl l) = returnUs (id, ImmCLbl l) + getData (StString s) = + getUniqLabelNCG `thenUs` \ lbl -> + returnUs (mkSeqInstrs [LABEL lbl, + ASCII True (_UNPK_ s)], + ImmCLbl lbl) +\end{code} + +%************************************************************************ +%* * +\subsection{General things for putting together code sequences} +%* * +%************************************************************************ + +\begin{code} +type InstrList = OrdList Instr +type InstrBlock = InstrList -> InstrList + +asmVoid :: InstrList +asmVoid = mkEmptyList + +asmInstr :: Instr -> InstrList +asmInstr i = mkUnitList i + +asmSeq :: [Instr] -> InstrList +asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is + +asmParThen :: [InstrList] -> InstrBlock +asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code + +returnInstr :: Instr -> UniqSM InstrBlock +returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs) + +returnInstrs :: [Instr] -> UniqSM InstrBlock +returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs) + +returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock +returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs)) + +mkSeqInstr :: Instr -> InstrBlock +mkSeqInstr instr code = mkSeqList (asmInstr instr) code + +mkSeqInstrs :: [Instr] -> InstrBlock +mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code +\end{code} + +\begin{code} +mangleIndexTree :: StixTree -> StixTree + +mangleIndexTree (StIndex pk base (StInt i)) + = StPrim IntAddOp [base, off] + where + off = StInt (i * sizeOf pk) + +mangleIndexTree (StIndex pk base off) + = StPrim IntAddOp [base, + case pk of + CharRep -> off + _ -> let + s = shift pk + in + ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk))) + StPrim SllOp [off, StInt s] + ] + where + shift DoubleRep = 3 + shift _ = IF_ARCH_alpha(3,2) +\end{code} + +\begin{code} +maybeImm :: StixTree -> Maybe Imm + +maybeImm (StLitLbl s) = Just (ImmLab s) +maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s))) +maybeImm (StCLbl l) = Just (ImmCLbl l) + +maybeImm (StInt i) + | i >= toInteger minInt && i <= toInteger maxInt + = Just (ImmInt (fromInteger i)) + | otherwise + = Just (ImmInteger i) + +maybeImm _ = Nothing +\end{code} + +%************************************************************************ +%* * +\subsection{The @Register@ type} +%* * +%************************************************************************ + +@Register@s passed up the tree. If the stix code forces the register +to live in a pre-decided machine register, it comes out as @Fixed@; +otherwise, it comes out as @Any@, and the parent can decide which +register to put it in. + +\begin{code} +data Register + = Fixed PrimRep Reg InstrBlock + | Any PrimRep (Reg -> InstrBlock) + +registerCode :: Register -> Reg -> InstrBlock +registerCode (Fixed _ _ code) reg = code +registerCode (Any _ code) reg = code reg + +registerName :: Register -> Reg -> Reg +registerName (Fixed _ reg _) _ = reg +registerName (Any _ _) reg = reg + +registerRep :: Register -> PrimRep +registerRep (Fixed pk _ _) = pk +registerRep (Any pk _) = pk + +isFixed :: Register -> Bool +isFixed (Fixed _ _ _) = True +isFixed (Any _ _) = False +\end{code} + +Generate code to get a subtree into a @Register@: +\begin{code} +getRegister :: StixTree -> UniqSM Register + +getRegister (StReg (StixMagicId stgreg)) + = case (magicIdRegMaybe stgreg) of + Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id) + -- cannae be Nothing + +getRegister (StReg (StixTemp u pk)) + = returnUs (Fixed pk (UnmappedReg u pk) id) + +getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) + +getRegister (StCall fn kind args) + = genCCall fn kind args `thenUs` \ call -> + returnUs (Fixed kind reg call) + where + reg = if isFloatingRep kind + then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,))) + else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,))) + +getRegister (StString s) + = getUniqLabelNCG `thenUs` \ lbl -> + let + imm_lbl = ImmCLbl lbl + + code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + ASCII True (_UNPK_ s), + SEGMENT TextSegment, +#if alpha_TARGET_ARCH + LDA dst (AddrImm imm_lbl) +#endif +#if i386_TARGET_ARCH + MOV L (OpImm imm_lbl) (OpReg dst) +#endif +#if sparc_TARGET_ARCH + SETHI (HI imm_lbl) dst, + OR False dst (RIImm (LO imm_lbl)) dst +#endif + ] + in + returnUs (Any PtrRep code) + +getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"' + = getUniqLabelNCG `thenUs` \ lbl -> + let + imm_lbl = ImmCLbl lbl + + code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + ASCII False (init xs), + SEGMENT TextSegment, +#if alpha_TARGET_ARCH + LDA dst (AddrImm imm_lbl) +#endif +#if i386_TARGET_ARCH + MOV L (OpImm imm_lbl) (OpReg dst) +#endif +#if sparc_TARGET_ARCH + SETHI (HI imm_lbl) dst, + OR False dst (RIImm (LO imm_lbl)) dst +#endif + ] + in + returnUs (Any PtrRep code) + where + xs = _UNPK_ (_TAIL_ s) + +-- end of machine-"independent" bit; here we go on the rest... + +#if alpha_TARGET_ARCH + +getRegister (StDouble d) + = getUniqLabelNCG `thenUs` \ lbl -> + getNewRegNCG PtrRep `thenUs` \ tmp -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + DATA TF [ImmLab (prettyToUn (ppRational d))], + SEGMENT TextSegment, + LDA tmp (AddrImm (ImmCLbl lbl)), + LD TF dst (AddrReg tmp)] + in + returnUs (Any DoubleRep code) + +getRegister (StPrim primop [x]) -- unary PrimOps + = case primop of + IntNegOp -> trivialUCode (NEG Q False) x + IntAbsOp -> trivialUCode (ABS Q) x + + NotOp -> trivialUCode NOT x + + FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x + DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x + + OrdOp -> coerceIntCode IntRep x + ChrOp -> chrCode x + + Float2IntOp -> coerceFP2Int x + Int2FloatOp -> coerceInt2FP pr x + Double2IntOp -> coerceFP2Int x + Int2DoubleOp -> coerceInt2FP pr x + + Double2FloatOp -> coerceFltCode x + Float2DoubleOp -> coerceFltCode x + + other_op -> getRegister (StCall fn DoubleRep [x]) + where + fn = case other_op of + FloatExpOp -> SLIT("exp") + FloatLogOp -> SLIT("log") + FloatSqrtOp -> SLIT("sqrt") + FloatSinOp -> SLIT("sin") + FloatCosOp -> SLIT("cos") + FloatTanOp -> SLIT("tan") + FloatAsinOp -> SLIT("asin") + FloatAcosOp -> SLIT("acos") + FloatAtanOp -> SLIT("atan") + FloatSinhOp -> SLIT("sinh") + FloatCoshOp -> SLIT("cosh") + FloatTanhOp -> SLIT("tanh") + DoubleExpOp -> SLIT("exp") + DoubleLogOp -> SLIT("log") + DoubleSqrtOp -> SLIT("sqrt") + DoubleSinOp -> SLIT("sin") + DoubleCosOp -> SLIT("cos") + DoubleTanOp -> SLIT("tan") + DoubleAsinOp -> SLIT("asin") + DoubleAcosOp -> SLIT("acos") + DoubleAtanOp -> SLIT("atan") + DoubleSinhOp -> SLIT("sinh") + DoubleCoshOp -> SLIT("cosh") + DoubleTanhOp -> SLIT("tanh") + where + pr = panic "MachCode.getRegister: no primrep needed for Alpha" + +getRegister (StPrim primop [x, y]) -- dyadic PrimOps + = case primop of + CharGtOp -> trivialCode (CMP LT) y x + CharGeOp -> trivialCode (CMP LE) y x + CharEqOp -> trivialCode (CMP EQ) x y + CharNeOp -> int_NE_code x y + CharLtOp -> trivialCode (CMP LT) x y + CharLeOp -> trivialCode (CMP LE) x y + + IntGtOp -> trivialCode (CMP LT) y x + IntGeOp -> trivialCode (CMP LE) y x + IntEqOp -> trivialCode (CMP EQ) x y + IntNeOp -> int_NE_code x y + IntLtOp -> trivialCode (CMP LT) x y + IntLeOp -> trivialCode (CMP LE) x y + + WordGtOp -> trivialCode (CMP ULT) y x + WordGeOp -> trivialCode (CMP ULE) x y + WordEqOp -> trivialCode (CMP EQ) x y + WordNeOp -> int_NE_code x y + WordLtOp -> trivialCode (CMP ULT) x y + WordLeOp -> trivialCode (CMP ULE) x y + + AddrGtOp -> trivialCode (CMP ULT) y x + AddrGeOp -> trivialCode (CMP ULE) y x + AddrEqOp -> trivialCode (CMP EQ) x y + AddrNeOp -> int_NE_code x y + AddrLtOp -> trivialCode (CMP ULT) x y + AddrLeOp -> trivialCode (CMP ULE) x y + + FloatGtOp -> cmpF_code (FCMP TF LE) EQ x y + FloatGeOp -> cmpF_code (FCMP TF LT) EQ x y + FloatEqOp -> cmpF_code (FCMP TF EQ) NE x y + FloatNeOp -> cmpF_code (FCMP TF EQ) EQ x y + FloatLtOp -> cmpF_code (FCMP TF LT) NE x y + FloatLeOp -> cmpF_code (FCMP TF LE) NE x y + + DoubleGtOp -> cmpF_code (FCMP TF LE) EQ x y + DoubleGeOp -> cmpF_code (FCMP TF LT) EQ x y + DoubleEqOp -> cmpF_code (FCMP TF EQ) NE x y + DoubleNeOp -> cmpF_code (FCMP TF EQ) EQ x y + DoubleLtOp -> cmpF_code (FCMP TF LT) NE x y + DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y + + IntAddOp -> trivialCode (ADD Q False) x y + IntSubOp -> trivialCode (SUB Q False) x y + IntMulOp -> trivialCode (MUL Q False) x y + IntQuotOp -> trivialCode (DIV Q False) x y + IntRemOp -> trivialCode (REM Q False) x y + + FloatAddOp -> trivialFCode FloatRep (FADD TF) x y + FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y + FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y + FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y + + DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y + DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y + DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y + DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y + + AndOp -> trivialCode AND x y + OrOp -> trivialCode OR x y + SllOp -> trivialCode SLL x y + SraOp -> trivialCode SRA x y + SrlOp -> trivialCode SRL x y + + ISllOp -> panic "AlphaGen:isll" + ISraOp -> panic "AlphaGen:isra" + ISrlOp -> panic "AlphaGen:isrl" + + FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y]) + DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y]) + where + {- ------------------------------------------------------------ + 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, so we + need to wrangle an integer register out of things. + -} + int_NE_code :: StixTree -> StixTree -> UniqSM Register + + int_NE_code x y + = trivialCode (CMP EQ) x y `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 + returnUs (Any IntRep code__2) + + {- ------------------------------------------------------------ + Comments for int_NE_code also apply to cmpF_code + -} + cmpF_code + :: (Reg -> Reg -> Reg -> Instr) + -> Cond + -> StixTree -> StixTree + -> UniqSM Register + + cmpF_code instr cond x y + = trivialFCode pr instr x y `thenUs` \ register -> + getNewRegNCG DoubleRep `thenUs` \ tmp -> + getUniqLabelNCG `thenUs` \ lbl -> + let + code = registerCode register tmp + result = registerName register tmp + + code__2 dst = code . mkSeqInstrs [ + OR zero (RIImm (ImmInt 1)) dst, + BF cond result (ImmCLbl lbl), + OR zero (RIReg zero) dst, + LABEL lbl] + in + returnUs (Any IntRep code__2) + where + pr = panic "trivialU?FCode: does not use PrimRep on Alpha" + ------------------------------------------------------------ + +getRegister (StInd pk mem) + = getAmode mem `thenUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + size = primRepToSize pk + code__2 dst = code . mkSeqInstr (LD size dst src) + in + returnUs (Any pk code__2) + +getRegister (StInt i) + | fits8Bits i + = let + code dst = mkSeqInstr (OR zero (RIImm src) dst) + in + returnUs (Any IntRep code) + | otherwise + = let + code dst = mkSeqInstr (LDI Q dst src) + in + returnUs (Any IntRep code) + where + src = ImmInt (fromInteger i) + +getRegister leaf + | maybeToBool imm + = let + code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) + in + returnUs (Any PtrRep code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id) + +getRegister (StDouble 0.0) + = let + code dst = mkSeqInstrs [FLDZ] + in + returnUs (Any DoubleRep code) + +getRegister (StDouble 1.0) + = let + code dst = mkSeqInstrs [FLD1] + in + returnUs (Any DoubleRep code) + +getRegister (StDouble d) + = getUniqLabelNCG `thenUs` \ lbl -> + --getNewRegNCG PtrRep `thenUs` \ tmp -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + DATA DF [dblImmLit d], + SEGMENT TextSegment, + FLD DF (OpImm (ImmCLbl lbl)) + ] + in + returnUs (Any DoubleRep code) + +getRegister (StPrim primop [x]) -- unary PrimOps + = case primop of + IntNegOp -> trivialUCode (NEGI L) x + IntAbsOp -> absIntCode x + + NotOp -> trivialUCode (NOT L) x + + FloatNegOp -> trivialUFCode FloatRep FCHS x + FloatSqrtOp -> trivialUFCode FloatRep FSQRT x + DoubleNegOp -> trivialUFCode DoubleRep FCHS x + + DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x + + OrdOp -> coerceIntCode IntRep x + ChrOp -> chrCode x + + Float2IntOp -> coerceFP2Int x + Int2FloatOp -> coerceInt2FP FloatRep x + Double2IntOp -> coerceFP2Int x + Int2DoubleOp -> coerceInt2FP DoubleRep x + + Double2FloatOp -> coerceFltCode x + Float2DoubleOp -> coerceFltCode x + + other_op -> + let + fixed_x = if is_float_op -- promote to double + then StPrim Float2DoubleOp [x] + else x + in + getRegister (StCall fn DoubleRep [x]) + where + (is_float_op, fn) + = case primop of + FloatExpOp -> (True, SLIT("exp")) + FloatLogOp -> (True, SLIT("log")) + + FloatSinOp -> (True, SLIT("sin")) + FloatCosOp -> (True, SLIT("cos")) + FloatTanOp -> (True, SLIT("tan")) + + FloatAsinOp -> (True, SLIT("asin")) + FloatAcosOp -> (True, SLIT("acos")) + FloatAtanOp -> (True, SLIT("atan")) + + FloatSinhOp -> (True, SLIT("sinh")) + FloatCoshOp -> (True, SLIT("cosh")) + FloatTanhOp -> (True, SLIT("tanh")) + + DoubleExpOp -> (False, SLIT("exp")) + DoubleLogOp -> (False, SLIT("log")) + + DoubleSinOp -> (False, SLIT("sin")) + DoubleCosOp -> (False, SLIT("cos")) + DoubleTanOp -> (False, SLIT("tan")) + + DoubleAsinOp -> (False, SLIT("asin")) + DoubleAcosOp -> (False, SLIT("acos")) + DoubleAtanOp -> (False, SLIT("atan")) + + DoubleSinhOp -> (False, SLIT("sinh")) + DoubleCoshOp -> (False, SLIT("cosh")) + DoubleTanhOp -> (False, SLIT("tanh")) + +getRegister (StPrim primop [x, y]) -- dyadic PrimOps + = case primop of + CharGtOp -> condIntReg GT x y + CharGeOp -> condIntReg GE x y + CharEqOp -> condIntReg EQ x y + CharNeOp -> condIntReg NE x y + CharLtOp -> condIntReg LT x y + CharLeOp -> condIntReg LE x y + + IntGtOp -> condIntReg GT x y + IntGeOp -> condIntReg GE x y + IntEqOp -> condIntReg EQ x y + IntNeOp -> condIntReg NE x y + IntLtOp -> condIntReg LT x y + IntLeOp -> condIntReg LE x y + + WordGtOp -> condIntReg GU x y + WordGeOp -> condIntReg GEU x y + WordEqOp -> condIntReg EQ x y + WordNeOp -> condIntReg NE x y + WordLtOp -> condIntReg LU x y + WordLeOp -> condIntReg LEU x y + + AddrGtOp -> condIntReg GU x y + AddrGeOp -> condIntReg GEU x y + AddrEqOp -> condIntReg EQ x y + AddrNeOp -> condIntReg NE x y + AddrLtOp -> condIntReg LU x y + AddrLeOp -> condIntReg LEU x y + + FloatGtOp -> condFltReg GT x y + FloatGeOp -> condFltReg GE x y + FloatEqOp -> condFltReg EQ x y + FloatNeOp -> condFltReg NE x y + FloatLtOp -> condFltReg LT x y + FloatLeOp -> condFltReg LE x y + + DoubleGtOp -> condFltReg GT x y + DoubleGeOp -> condFltReg GE x y + DoubleEqOp -> condFltReg EQ x y + DoubleNeOp -> condFltReg NE x y + DoubleLtOp -> condFltReg LT x y + DoubleLeOp -> condFltReg LE x y + + IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)... + -- this should be optimised by the generic Opts, + -- I don't know why it is not (sometimes)! + case args of + [x, StInt 0] -> getRegister x + _ -> add_code L x y + -} + add_code L x y + + IntSubOp -> sub_code L x y + IntQuotOp -> quot_code L x y True{-division-} + IntRemOp -> quot_code L x y False{-remainder-} + IntMulOp -> trivialCode (IMUL L) x y {-True-} + + FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y + FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y + FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y + FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y + + DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y + DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y + DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y + DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y + + AndOp -> trivialCode (AND L) x y {-True-} + OrOp -> trivialCode (OR L) x y {-True-} + SllOp -> trivialCode (SHL L) x y {-False-} + SraOp -> trivialCode (SAR L) x y {-False-} + SrlOp -> trivialCode (SHR L) x y {-False-} + + ISllOp -> panic "I386Gen:isll" + ISraOp -> panic "I386Gen:isra" + ISrlOp -> panic "I386Gen:isrl" + + FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y]) + where promote x = StPrim Float2DoubleOp [x] + DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y]) + where + add_code :: Size -> StixTree -> StixTree -> UniqSM Register + + add_code sz x (StInt y) + = getRegister 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)) + in + returnUs (Any IntRep code__2) + + add_code sz x (StInd _ mem) + = getRegister x `thenUs` \ register1 -> + --getNewRegNCG (registerRep register1) + -- `thenUs` \ tmp1 -> + getAmode mem `thenUs` \ amode -> + let + code2 = amodeCode amode + src2 = amodeAddr amode + + fixedname = registerName register1 eax + 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)] + in + returnUs (Any IntRep code__2) + + add_code sz (StInd _ mem) y + = getRegister y `thenUs` \ register2 -> + --getNewRegNCG (registerRep register2) + -- `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)] + in + returnUs (Any IntRep code__2) + + add_code sz x y + = getRegister x `thenUs` \ register1 -> + getRegister 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)) + in + returnUs (Any IntRep code__2) + + -------------------- + sub_code :: Size -> StixTree -> StixTree -> UniqSM Register + + sub_code sz x (StInt y) + = getRegister 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)) + in + returnUs (Any IntRep code__2) + + sub_code sz x y = trivialCode (SUB sz) x y {-False-} + + -------------------- + quot_code + :: Size + -> StixTree -> StixTree + -> Bool -- True => division, False => remainder operation + -> UniqSM Register + + -- 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) + + quot_code sz x (StInd pk mem) is_division + = getRegister 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)] + in + returnUs (Fixed IntRep (if is_division then eax else edx) code__2) + + quot_code sz x (StInt i) is_division + = getRegister 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)))] + in + returnUs (Fixed IntRep (if is_division then eax else edx) code__2) + + quot_code sz x y is_division + = getRegister x `thenUs` \ register1 -> + getNewRegNCG IntRep `thenUs` \ tmp1 -> + getRegister 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)))] + in + returnUs (Fixed IntRep (if is_division then eax else edx) code__2) + ----------------------- + +getRegister (StInd pk mem) + = getAmode mem `thenUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + size = primRepToSize pk + code__2 dst = code . + if pk == DoubleRep || pk == FloatRep + then mkSeqInstr (FLD {-DF-} size (OpAddr src)) + else mkSeqInstr (MOV size (OpAddr src) (OpReg dst)) + in + returnUs (Any pk code__2) + + +getRegister (StInt i) + = let + src = ImmInt (fromInteger i) + code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst)) + in + returnUs (Any IntRep code) + +getRegister leaf + | maybeToBool imm + = let + code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst)) + in + returnUs (Any PtrRep code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +getRegister (StDouble d) + = getUniqLabelNCG `thenUs` \ lbl -> + getNewRegNCG PtrRep `thenUs` \ tmp -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + DATA DF [dblImmLit d], + SEGMENT TextSegment, + SETHI (HI (ImmCLbl lbl)) tmp, + LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + in + returnUs (Any DoubleRep code) + +getRegister (StPrim primop [x]) -- unary PrimOps + = case primop of + IntNegOp -> trivialUCode (SUB False False g0) x + IntAbsOp -> absIntCode x + + NotOp -> trivialUCode (XNOR False g0) x + + FloatNegOp -> trivialUFCode FloatRep (FNEG F) x + DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x + + Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x + Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x + + OrdOp -> coerceIntCode IntRep x + ChrOp -> chrCode x + + Float2IntOp -> coerceFP2Int x + Int2FloatOp -> coerceInt2FP FloatRep x + Double2IntOp -> coerceFP2Int x + Int2DoubleOp -> coerceInt2FP DoubleRep x + + other_op -> + let + fixed_x = if is_float_op -- promote to double + then StPrim Float2DoubleOp [x] + else x + in + getRegister (StCall fn DoubleRep [x]) + where + (is_float_op, fn) + = case primop of + FloatExpOp -> (True, SLIT("exp")) + FloatLogOp -> (True, SLIT("log")) + + FloatSinOp -> (True, SLIT("sin")) + FloatCosOp -> (True, SLIT("cos")) + FloatTanOp -> (True, SLIT("tan")) + + FloatAsinOp -> (True, SLIT("asin")) + FloatAcosOp -> (True, SLIT("acos")) + FloatAtanOp -> (True, SLIT("atan")) + + FloatSinhOp -> (True, SLIT("sinh")) + FloatCoshOp -> (True, SLIT("cosh")) + FloatTanhOp -> (True, SLIT("tanh")) + + DoubleExpOp -> (False, SLIT("exp")) + DoubleLogOp -> (False, SLIT("log")) + + DoubleSinOp -> (False, SLIT("sin")) + DoubleCosOp -> (False, SLIT("cos")) + DoubleTanOp -> (False, SLIT("tan")) + + DoubleAsinOp -> (False, SLIT("asin")) + DoubleAcosOp -> (False, SLIT("acos")) + DoubleAtanOp -> (False, SLIT("atan")) + + DoubleSinhOp -> (False, SLIT("sinh")) + DoubleCoshOp -> (False, SLIT("cosh")) + DoubleTanhOp -> (False, SLIT("tanh")) + +getRegister (StPrim primop [x, y]) -- dyadic PrimOps + = case primop of + CharGtOp -> condIntReg GT x y + CharGeOp -> condIntReg GE x y + CharEqOp -> condIntReg EQ x y + CharNeOp -> condIntReg NE x y + CharLtOp -> condIntReg LT x y + CharLeOp -> condIntReg LE x y + + IntGtOp -> condIntReg GT x y + IntGeOp -> condIntReg GE x y + IntEqOp -> condIntReg EQ x y + IntNeOp -> condIntReg NE x y + IntLtOp -> condIntReg LT x y + IntLeOp -> condIntReg LE x y + + WordGtOp -> condIntReg GU x y + WordGeOp -> condIntReg GEU x y + WordEqOp -> condIntReg EQ x y + WordNeOp -> condIntReg NE x y + WordLtOp -> condIntReg LU x y + WordLeOp -> condIntReg LEU x y + + AddrGtOp -> condIntReg GU x y + AddrGeOp -> condIntReg GEU x y + AddrEqOp -> condIntReg EQ x y + AddrNeOp -> condIntReg NE x y + AddrLtOp -> condIntReg LU x y + AddrLeOp -> condIntReg LEU x y + + FloatGtOp -> condFltReg GT x y + FloatGeOp -> condFltReg GE x y + FloatEqOp -> condFltReg EQ x y + FloatNeOp -> condFltReg NE x y + FloatLtOp -> condFltReg LT x y + FloatLeOp -> condFltReg LE x y + + DoubleGtOp -> condFltReg GT x y + DoubleGeOp -> condFltReg GE x y + DoubleEqOp -> condFltReg EQ x y + DoubleNeOp -> condFltReg NE x y + DoubleLtOp -> condFltReg LT x y + DoubleLeOp -> condFltReg LE x y + + IntAddOp -> trivialCode (ADD False False) x y + IntSubOp -> trivialCode (SUB False False) x y + + -- ToDo: teach about V8+ SPARC mul/div instructions + IntMulOp -> imul_div SLIT(".umul") x y + IntQuotOp -> imul_div SLIT(".div") x y + IntRemOp -> imul_div SLIT(".rem") x y + + FloatAddOp -> trivialFCode FloatRep FADD x y + FloatSubOp -> trivialFCode FloatRep FSUB x y + FloatMulOp -> trivialFCode FloatRep FMUL x y + FloatDivOp -> trivialFCode FloatRep FDIV x y + + DoubleAddOp -> trivialFCode DoubleRep FADD x y + DoubleSubOp -> trivialFCode DoubleRep FSUB x y + DoubleMulOp -> trivialFCode DoubleRep FMUL x y + DoubleDivOp -> trivialFCode DoubleRep FDIV x y + + AndOp -> trivialCode (AND False) x y + OrOp -> trivialCode (OR False) x y + SllOp -> trivialCode SLL x y + SraOp -> trivialCode SRA x y + SrlOp -> trivialCode SRL x y + + ISllOp -> panic "SparcGen:isll" + ISraOp -> panic "SparcGen:isra" + ISrlOp -> panic "SparcGen:isrl" + + FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y]) + where promote x = StPrim Float2DoubleOp [x] + DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y]) + where + imul_div fn x y = getRegister (StCall fn IntRep [x, y]) + +getRegister (StInd pk mem) + = getAmode mem `thenUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + size = primRepToSize pk + code__2 dst = code . mkSeqInstr (LD size src dst) + in + returnUs (Any pk code__2) + +getRegister (StInt i) + | fits13Bits i + = let + src = ImmInt (fromInteger i) + code dst = mkSeqInstr (OR False g0 (RIImm src) dst) + in + returnUs (Any IntRep code) + +getRegister leaf + | maybeToBool imm + = let + code dst = mkSeqInstrs [ + SETHI (HI imm__2) dst, + OR False dst (RIImm (LO imm__2)) dst] + in + returnUs (Any PtrRep code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{The @Amode@ type} +%* * +%************************************************************************ + +@Amode@s: Memory addressing modes passed up the tree. +\begin{code} +data Amode = Amode Addr InstrBlock + +amodeAddr (Amode addr _) = addr +amodeCode (Amode _ code) = code +\end{code} + +Now, given a tree (the argument to an StInd) that references memory, +produce a suitable addressing mode. + +\begin{code} +getAmode :: StixTree -> UniqSM Amode + +getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) + +#if alpha_TARGET_ARCH + +getAmode (StPrim IntSubOp [x, StInt i]) + = getNewRegNCG PtrRep `thenUs` \ tmp -> + getRegister x `thenUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (-(fromInteger i)) + in + returnUs (Amode (AddrRegImm reg off) code) + +getAmode (StPrim IntAddOp [x, StInt i]) + = getNewRegNCG PtrRep `thenUs` \ tmp -> + getRegister x `thenUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (fromInteger i) + in + returnUs (Amode (AddrRegImm reg off) code) + +getAmode leaf + | maybeToBool imm + = returnUs (Amode (AddrImm imm__2) id) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +getAmode other + = getNewRegNCG PtrRep `thenUs` \ tmp -> + getRegister other `thenUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + in + returnUs (Amode (AddrReg reg) code) + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +getAmode (StPrim IntSubOp [x, StInt i]) + = getNewRegNCG PtrRep `thenUs` \ tmp -> + getRegister x `thenUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (-(fromInteger i)) + in + returnUs (Amode (Addr (Just reg) Nothing off) code) + +getAmode (StPrim IntAddOp [x, StInt i]) + | maybeToBool imm + = let + code = mkSeqInstrs [] + in + 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 PtrRep `thenUs` \ tmp -> + getRegister x `thenUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (fromInteger i) + in + returnUs (Amode (Addr (Just reg) Nothing off) code) + +getAmode (StPrim IntAddOp [x, y]) + = getNewRegNCG PtrRep `thenUs` \ tmp1 -> + getNewRegNCG IntRep `thenUs` \ tmp2 -> + getRegister x `thenUs` \ register1 -> + getRegister y `thenUs` \ register2 -> + let + code1 = registerCode register1 tmp1 asmVoid + reg1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + reg2 = registerName register2 tmp2 + code__2 = asmParThen [code1, code2] + in + returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) + +getAmode leaf + | maybeToBool imm + = let + code = mkSeqInstrs [] + in + returnUs (Amode (ImmAddr imm__2 0) code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +getAmode other + = getNewRegNCG PtrRep `thenUs` \ tmp -> + getRegister other `thenUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = Nothing + in + returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code) + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +getAmode (StPrim IntSubOp [x, StInt i]) + | fits13Bits (-i) + = getNewRegNCG PtrRep `thenUs` \ tmp -> + getRegister x `thenUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (-(fromInteger i)) + in + returnUs (Amode (AddrRegImm reg off) code) + + +getAmode (StPrim IntAddOp [x, StInt i]) + | fits13Bits i + = getNewRegNCG PtrRep `thenUs` \ tmp -> + getRegister x `thenUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (fromInteger i) + in + returnUs (Amode (AddrRegImm reg off) code) + +getAmode (StPrim IntAddOp [x, y]) + = getNewRegNCG PtrRep `thenUs` \ tmp1 -> + getNewRegNCG IntRep `thenUs` \ tmp2 -> + getRegister x `thenUs` \ register1 -> + getRegister y `thenUs` \ register2 -> + let + code1 = registerCode register1 tmp1 asmVoid + reg1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + reg2 = registerName register2 tmp2 + code__2 = asmParThen [code1, code2] + in + returnUs (Amode (AddrRegReg reg1 reg2) code__2) + +getAmode leaf + | maybeToBool imm + = getNewRegNCG PtrRep `thenUs` \ tmp -> + let + code = mkSeqInstr (SETHI (HI imm__2) tmp) + in + returnUs (Amode (AddrRegImm tmp (LO imm__2)) code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +getAmode other + = getNewRegNCG PtrRep `thenUs` \ tmp -> + getRegister other `thenUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt 0 + in + returnUs (Amode (AddrRegImm reg off) code) + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{The @CondCode@ type} +%* * +%************************************************************************ + +Condition codes passed up the tree. +\begin{code} +data CondCode = CondCode Bool Cond InstrBlock + +condName (CondCode _ cond _) = cond +condFloat (CondCode is_float _ _) = is_float +condCode (CondCode _ _ code) = code +\end{code} + +Set up a condition code for a conditional branch. + +\begin{code} +getCondCode :: StixTree -> UniqSM CondCode + +#if alpha_TARGET_ARCH +getCondCode = panic "MachCode.getCondCode: not on Alphas" +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +#if i386_TARGET_ARCH || sparc_TARGET_ARCH +-- yes, they really do seem to want exactly the same! + +getCondCode (StPrim primop [x, y]) + = case primop of + CharGtOp -> condIntCode GT x y + CharGeOp -> condIntCode GE x y + CharEqOp -> condIntCode EQ x y + CharNeOp -> condIntCode NE x y + CharLtOp -> condIntCode LT x y + CharLeOp -> condIntCode LE x y + + IntGtOp -> condIntCode GT x y + IntGeOp -> condIntCode GE x y + IntEqOp -> condIntCode EQ x y + IntNeOp -> condIntCode NE x y + IntLtOp -> condIntCode LT x y + IntLeOp -> condIntCode LE x y + + WordGtOp -> condIntCode GU x y + WordGeOp -> condIntCode GEU x y + WordEqOp -> condIntCode EQ x y + WordNeOp -> condIntCode NE x y + WordLtOp -> condIntCode LU x y + WordLeOp -> condIntCode LEU x y + + AddrGtOp -> condIntCode GU x y + AddrGeOp -> condIntCode GEU x y + AddrEqOp -> condIntCode EQ x y + AddrNeOp -> condIntCode NE x y + AddrLtOp -> condIntCode LU x y + AddrLeOp -> condIntCode LEU x y + + FloatGtOp -> condFltCode GT x y + FloatGeOp -> condFltCode GE x y + FloatEqOp -> condFltCode EQ x y + FloatNeOp -> condFltCode NE x y + FloatLtOp -> condFltCode LT x y + FloatLeOp -> condFltCode LE x y + + DoubleGtOp -> condFltCode GT x y + DoubleGeOp -> condFltCode GE x y + DoubleEqOp -> condFltCode EQ x y + DoubleNeOp -> condFltCode NE x y + DoubleLtOp -> condFltCode LT x y + DoubleLeOp -> condFltCode LE x y + +#endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -} +\end{code} + +% ----------------- + +@cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +passed back up the tree. + +\begin{code} +condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode + +#if alpha_TARGET_ARCH +condIntCode = panic "MachCode.condIntCode: not on Alphas" +condFltCode = panic "MachCode.condFltCode: not on Alphas" +#endif {- alpha_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +condIntCode cond (StInd _ x) y + | maybeToBool imm + = getAmode x `thenUs` \ amode -> + let + code1 = amodeCode amode asmVoid + y__2 = amodeAddr amode + code__2 = asmParThen [code1] . + mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2)) + in + returnUs (CondCode False cond code__2) + where + imm = maybeImm y + imm__2 = case imm of Just x -> x + +condIntCode cond x (StInt 0) + = getRegister x `thenUs` \ register1 -> + getNewRegNCG IntRep `thenUs` \ tmp1 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code__2 = asmParThen [code1] . + mkSeqInstr (TEST L (OpReg src1) (OpReg src1)) + in + returnUs (CondCode False cond code__2) + +condIntCode cond x y + | maybeToBool imm + = getRegister x `thenUs` \ register1 -> + getNewRegNCG IntRep `thenUs` \ tmp1 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code__2 = asmParThen [code1] . + mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1)) + in + returnUs (CondCode False cond code__2) + where + imm = maybeImm y + imm__2 = case imm of Just x -> x + +condIntCode cond (StInd _ x) y + = getAmode x `thenUs` \ amode -> + getRegister 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] . + mkSeqInstr (CMP L (OpReg src2) (OpAddr src1)) + in + returnUs (CondCode False cond code__2) + +condIntCode cond y (StInd _ x) + = getAmode x `thenUs` \ amode -> + getRegister 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] . + mkSeqInstr (CMP L (OpAddr src1) (OpReg src2)) + in + returnUs (CondCode False cond code__2) + +condIntCode cond x y + = getRegister x `thenUs` \ register1 -> + getRegister 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] . + mkSeqInstr (CMP L (OpReg src2) (OpReg src1)) + in + returnUs (CondCode False cond code__2) + +----------- + +condFltCode cond x (StDouble 0.0) + = getRegister x `thenUs` \ register1 -> + getNewRegNCG (registerRep register1) + `thenUs` \ tmp1 -> + let + pk1 = registerRep register1 + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + code__2 = asmParThen [code1 asmVoid] . + mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ? + FNSTSW, + --AND HB (OpImm (ImmInt 68)) (OpReg eax), + --XOR HB (OpImm (ImmInt 64)) (OpReg eax) + SAHF + ] + in + returnUs (CondCode True (fix_FP_cond cond) code__2) + +condFltCode cond x y + = getRegister x `thenUs` \ register1 -> + getRegister y `thenUs` \ register2 -> + getNewRegNCG (registerRep register1) + `thenUs` \ tmp1 -> + getNewRegNCG (registerRep register2) + `thenUs` \ tmp2 -> + let + pk1 = registerRep register1 + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 + + 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 + ] + in + returnUs (CondCode True (fix_FP_cond cond) code__2) + +{- On the 486, the flags set by FP compare are the unsigned ones! + (This looks like a HACK to me. WDP 96/03) +-} + +fix_FP_cond :: Cond -> Cond + +fix_FP_cond GE = GEU +fix_FP_cond GT = GU +fix_FP_cond LT = LU +fix_FP_cond LE = LEU +fix_FP_cond any = any + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +condIntCode cond x (StInt y) + | fits13Bits y + = getRegister x `thenUs` \ register -> + getNewRegNCG IntRep `thenUs` \ tmp -> + let + code = registerCode register tmp + src1 = registerName register tmp + src2 = ImmInt (fromInteger y) + code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0) + in + returnUs (CondCode False cond code__2) + +condIntCode cond x y + = getRegister x `thenUs` \ register1 -> + getRegister 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] . + mkSeqInstr (SUB False True src1 (RIReg src2) g0) + in + returnUs (CondCode False cond code__2) + +----------- +condFltCode cond x y + = getRegister x `thenUs` \ register1 -> + getRegister y `thenUs` \ register2 -> + getNewRegNCG (registerRep register1) + `thenUs` \ tmp1 -> + getNewRegNCG (registerRep register2) + `thenUs` \ tmp2 -> + getNewRegNCG DoubleRep `thenUs` \ tmp -> + let + promote x = asmInstr (FxTOy F DF x tmp) + + pk1 = registerRep register1 + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + pk2 = registerRep register2 + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 + + code__2 = + if pk1 == pk2 then + asmParThen [code1 asmVoid, code2 asmVoid] . + mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2) + else if pk1 == FloatRep then + asmParThen [code1 (promote src1), code2 asmVoid] . + mkSeqInstr (FCMP True DF tmp src2) + else + asmParThen [code1 asmVoid, code2 (promote src2)] . + mkSeqInstr (FCMP True DF src1 tmp) + in + returnUs (CondCode True cond code__2) + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{Generating assignments} +%* * +%************************************************************************ + +Assignments are really at the heart of the whole code generation +business. Almost all top-level nodes of any real importance are +assignments, which correspond to loads, stores, or register transfers. +If we're really lucky, 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). + +\begin{code} +assignIntCode, assignFltCode + :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock + +#if alpha_TARGET_ARCH + +assignIntCode pk (StInd _ dst) src + = getNewRegNCG IntRep `thenUs` \ tmp -> + getAmode dst `thenUs` \ amode -> + getRegister src `thenUs` \ register -> + let + code1 = amodeCode amode asmVoid + dst__2 = amodeAddr amode + code2 = registerCode register tmp asmVoid + src__2 = registerName register tmp + sz = primRepToSize pk + code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + in + returnUs code__2 + +assignIntCode pk dst src + = getRegister dst `thenUs` \ register1 -> + getRegister 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 . mkSeqInstr (OR src__2 (RIReg src__2) dst__2) + else code + in + returnUs code__2 + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +assignIntCode pk (StInd _ dst) src + = getAmode dst `thenUs` \ amode -> + get_op_RI 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)) + in + returnUs code__2 + where + get_op_RI + :: StixTree + -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size + + get_op_RI op + | maybeToBool imm + = returnUs (asmParThen [], OpImm imm_op, L) + where + imm = maybeImm op + imm_op = case imm of Just x -> x + + get_op_RI op + = getRegister op `thenUs` \ register -> + getNewRegNCG (registerRep register) + `thenUs` \ tmp -> + let + code = registerCode register tmp + reg = registerName register tmp + pk = registerRep register + sz = primRepToSize pk + in + returnUs (code, OpReg reg, sz) + +assignIntCode pk dst (StInd _ src) + = getNewRegNCG IntRep `thenUs` \ tmp -> + getAmode src `thenUs` \ amode -> + getRegister dst `thenUs` \ register -> + let + code1 = amodeCode amode asmVoid + src__2 = amodeAddr amode + code2 = registerCode register tmp asmVoid + dst__2 = registerName register tmp + sz = primRepToSize pk + code__2 = asmParThen [code1, code2] . + mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2)) + in + returnUs code__2 + +assignIntCode pk dst src + = getRegister dst `thenUs` \ register1 -> + getRegister 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 + in + returnUs code__2 + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +assignIntCode pk (StInd _ dst) src + = getNewRegNCG IntRep `thenUs` \ tmp -> + getAmode dst `thenUs` \ amode -> + getRegister src `thenUs` \ register -> + let + code1 = amodeCode amode asmVoid + dst__2 = amodeAddr amode + code2 = registerCode register tmp asmVoid + src__2 = registerName register tmp + sz = primRepToSize pk + code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + in + returnUs code__2 + +assignIntCode pk dst src + = getRegister dst `thenUs` \ register1 -> + getRegister 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 . mkSeqInstr (OR False g0 (RIReg src__2) dst__2) + else code + in + returnUs code__2 + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +% -------------------------------- +Floating-point assignments: +% -------------------------------- +\begin{code} +#if alpha_TARGET_ARCH + +assignFltCode pk (StInd _ dst) src + = getNewRegNCG pk `thenUs` \ tmp -> + getAmode dst `thenUs` \ amode -> + getRegister src `thenUs` \ register -> + let + code1 = amodeCode amode asmVoid + dst__2 = amodeAddr amode + code2 = registerCode register tmp asmVoid + src__2 = registerName register tmp + sz = primRepToSize pk + code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + in + returnUs code__2 + +assignFltCode pk dst src + = getRegister dst `thenUs` \ register1 -> + getRegister 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 . mkSeqInstr (FMOV src__2 dst__2) + else code + in + returnUs code__2 + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +assignFltCode pk (StInd pk_dst dst) (StInd pk_src src) + = getNewRegNCG IntRep `thenUs` \ tmp -> + getAmode src `thenUs` \ amodesrc -> + getAmode dst `thenUs` \ amodedst -> + --getRegister src `thenUs` \ register -> + let + codesrc1 = amodeCode amodesrc asmVoid + addrsrc1 = amodeAddr amodesrc + codedst1 = amodeCode amodedst asmVoid + addrdst1 = amodeAddr amodedst + addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x + addrdst2 = case (addrOffset addrdst1 4) of Just x -> x + + code__2 = asmParThen [codesrc1, codedst1] . + mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp), + MOV L (OpReg tmp) (OpAddr addrdst1)] + ++ + if pk == DoubleRep + then [MOV L (OpAddr addrsrc2) (OpReg tmp), + MOV L (OpReg tmp) (OpAddr addrdst2)] + else []) + in + returnUs code__2 + +assignFltCode pk (StInd _ dst) src + = --getNewRegNCG pk `thenUs` \ tmp -> + getAmode dst `thenUs` \ amode -> + getRegister src `thenUs` \ register -> + let + sz = primRepToSize pk + dst__2 = amodeAddr amode + + code1 = amodeCode amode asmVoid + code2 = registerCode register {-tmp-}st0 asmVoid + + --src__2= registerName register tmp + pk__2 = registerRep register + sz__2 = primRepToSize pk__2 + + code__2 = asmParThen [code1, code2] . + mkSeqInstr (FSTP sz (OpAddr dst__2)) + in + returnUs code__2 + +assignFltCode pk dst src + = getRegister dst `thenUs` \ register1 -> + getRegister src `thenUs` \ register2 -> + --getNewRegNCG (registerRep register2) + -- `thenUs` \ tmp -> + let + sz = primRepToSize pk + dst__2 = registerName register1 st0 --tmp + + code = registerCode register2 dst__2 + src__2 = registerName register2 dst__2 + + code__2 = code + in + returnUs code__2 + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +assignFltCode pk (StInd _ dst) src + = getNewRegNCG pk `thenUs` \ tmp -> + getAmode dst `thenUs` \ amode -> + getRegister src `thenUs` \ register -> + let + sz = primRepToSize pk + dst__2 = amodeAddr amode + + code1 = amodeCode amode asmVoid + code2 = registerCode register tmp asmVoid + + src__2 = registerName register tmp + pk__2 = registerRep register + sz__2 = primRepToSize pk__2 + + 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 + returnUs code__2 + +assignFltCode pk dst src + = getRegister dst `thenUs` \ register1 -> + getRegister src `thenUs` \ register2 -> + getNewRegNCG (registerRep register2) + `thenUs` \ tmp -> + let + sz = primRepToSize pk + dst__2 = registerName register1 g0 -- must be Fixed + + reg__2 = if pk /= pk__2 then tmp else dst__2 + + code = registerCode register2 reg__2 + src__2 = registerName register2 reg__2 + pk__2 = registerRep register2 + sz__2 = primRepToSize pk__2 + + code__2 = if pk /= pk__2 then + code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2) + else if isFixed register2 then + code . mkSeqInstr (FMOV sz src__2 dst__2) + else + code + in + returnUs code__2 + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{Generating an unconditional branch} +%* * +%************************************************************************ + +We accept two types of targets: an immediate CLabel or a tree that +gets evaluated into a register. Any CLabels which are AsmTemporaries +are assumed to be in the local block of code, close enough for a +branch instruction. Other CLabels are assumed to be far away. + +(If applicable) Do not fill the delay slots here; you will confuse the +register allocator. + +\begin{code} +genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock + +#if alpha_TARGET_ARCH + +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 + = getRegister tree `thenUs` \ register -> + getNewRegNCG PtrRep `thenUs` \ tmp -> + let + dst = registerName register pv + code = registerCode register pv + target = registerName register pv + in + if isFixed register then + returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0] + else + returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0)) + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +{- +genJump (StCLbl lbl) + | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl] + | otherwise = returnInstrs [JMP (OpImm target)] + where + target = ImmCLbl lbl +-} + +genJump (StInd pk mem) + = getAmode mem `thenUs` \ amode -> + let + code = amodeCode amode + target = amodeAddr amode + in + returnSeq code [JMP (OpAddr target)] + +genJump tree + | maybeToBool imm + = returnInstr (JMP (OpImm target)) + + | otherwise + = getRegister tree `thenUs` \ register -> + getNewRegNCG PtrRep `thenUs` \ tmp -> + let + code = registerCode register tmp + target = registerName register tmp + in + returnSeq code [JMP (OpReg target)] + where + imm = maybeImm tree + target = case imm of Just x -> x + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +genJump (StCLbl lbl) + | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP] + | otherwise = returnInstrs [CALL target 0 True, NOP] + where + target = ImmCLbl lbl + +genJump tree + = getRegister tree `thenUs` \ register -> + getNewRegNCG PtrRep `thenUs` \ tmp -> + let + code = registerCode register tmp + target = registerName register tmp + in + returnSeq code [JMP (AddrRegReg target g0), NOP] + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{Conditional jumps} +%* * +%************************************************************************ + +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. + +ALPHA: For comparisons with 0, we're laughing, because we can just do +the desired conditional branch. + +I386: First, we have to ensure that the condition +codes are set according to the supplied comparison operation. + +SPARC: First, we have to ensure that the condition codes are set +according to the supplied comparison operation. We generate slightly +different code for floating point comparisons, because a floating +point operation cannot directly precede a @BF@. We assume the worst +and fill that slot with a @NOP@. + +SPARC: Do not fill the delay slots here; you will confuse the register +allocator. + +\begin{code} +genCondJump + :: CLabel -- the branch target + -> StixTree -- the condition on which to branch + -> UniqSM InstrBlock + +#if alpha_TARGET_ARCH + +genCondJump lbl (StPrim op [x, StInt 0]) + = getRegister x `thenUs` \ register -> + getNewRegNCG (registerRep register) + `thenUs` \ tmp -> + let + code = registerCode register tmp + value = registerName register tmp + pk = registerRep register + target = ImmCLbl lbl + in + returnSeq code [BI (cmpOp op) value target] + where + cmpOp CharGtOp = GT + cmpOp CharGeOp = GE + cmpOp CharEqOp = EQ + cmpOp CharNeOp = NE + cmpOp CharLtOp = LT + cmpOp CharLeOp = LE + cmpOp IntGtOp = GT + cmpOp IntGeOp = GE + cmpOp IntEqOp = EQ + cmpOp IntNeOp = NE + cmpOp IntLtOp = LT + cmpOp IntLeOp = LE + cmpOp WordGtOp = NE + cmpOp WordGeOp = ALWAYS + cmpOp WordEqOp = EQ + cmpOp WordNeOp = NE + cmpOp WordLtOp = NEVER + cmpOp WordLeOp = EQ + cmpOp AddrGtOp = NE + cmpOp AddrGeOp = ALWAYS + cmpOp AddrEqOp = EQ + cmpOp AddrNeOp = NE + cmpOp AddrLtOp = NEVER + cmpOp AddrLeOp = EQ + +genCondJump lbl (StPrim op [x, StDouble 0.0]) + = getRegister x `thenUs` \ register -> + getNewRegNCG (registerRep register) + `thenUs` \ tmp -> + let + code = registerCode register tmp + value = registerName register tmp + pk = registerRep register + target = ImmCLbl lbl + in + returnUs (code . mkSeqInstr (BF (cmpOp op) value target)) + where + cmpOp FloatGtOp = GT + cmpOp FloatGeOp = GE + cmpOp FloatEqOp = EQ + cmpOp FloatNeOp = NE + cmpOp FloatLtOp = LT + cmpOp FloatLeOp = LE + cmpOp DoubleGtOp = GT + cmpOp DoubleGeOp = GE + cmpOp DoubleEqOp = EQ + cmpOp DoubleNeOp = NE + cmpOp DoubleLtOp = LT + cmpOp DoubleLeOp = LE + +genCondJump lbl (StPrim op [x, y]) + | fltCmpOp op + = trivialFCode pr instr x y `thenUs` \ register -> + getNewRegNCG DoubleRep `thenUs` \ tmp -> + let + code = registerCode register tmp + result = registerName register tmp + target = ImmCLbl lbl + in + returnUs (code . mkSeqInstr (BF cond result target)) + where + pr = panic "trivialU?FCode: does not use PrimRep on Alpha" + + 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 + (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) + +genCondJump lbl (StPrim op [x, y]) + = trivialCode instr x y `thenUs` \ register -> + getNewRegNCG IntRep `thenUs` \ tmp -> + let + code = registerCode register tmp + result = registerName register tmp + target = ImmCLbl lbl + in + 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) + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +genCondJump lbl bool + = getCondCode bool `thenUs` \ condition -> + let + code = condCode condition + cond = condName condition + target = ImmCLbl lbl + in + returnSeq code [JXX cond lbl] + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +genCondJump lbl bool + = getCondCode bool `thenUs` \ condition -> + let + code = condCode condition + cond = condName condition + target = ImmCLbl lbl + in + returnSeq code ( + if condFloat condition then + [NOP, BF cond False target, NOP] + else + [BI cond False target, NOP] + ) + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{Generating C calls} +%* * +%************************************************************************ + +Now the biggest nightmare---calls. Most of the nastiness is buried in +@get_arg@, which moves the arguments to the correct registers/stack +locations. Apart from that, the code is easy. + +(If applicable) Do not fill the delay slots here; you will confuse the +register allocator. + +\begin{code} +genCCall + :: FAST_STRING -- function to call + -> PrimRep -- type of the result + -> [StixTree] -- arguments (of mixed type) + -> UniqSM InstrBlock + +#if alpha_TARGET_ARCH + +genCCall fn kind args + = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args + `thenUs` \ ((unused,_), argCode) -> + let + nRegs = length allArgRegs - length unused + code = asmParThen (map ($ asmVoid) argCode) + in + returnSeq code [ + LDA pv (AddrImm (ImmLab (uppPStr fn))), + JSR ra (AddrReg pv) nRegs, + LDGP gp (AddrReg ra)] + where + ------------------------ + {- Try to get a value into a specific register (or registers) for + a call. The first 6 arguments go into the appropriate + argument register (separate registers for integer and floating + point arguments, but used in lock-step), and the remaining + arguments are dumped to the stack, beginning at 0(sp). Our + first argument is a pair of the list of remaining argument + registers to be assigned for this call and the next stack + offset to use for overflowing arguments. This way, + @get_Arg@ can be applied to all of a call's arguments using + @mapAccumLUs@. + -} + get_arg + :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator) + -> StixTree -- Current argument + -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code + + -- We have to use up all of our argument registers first... + + get_arg ((iDst,fDst):dsts, offset) arg + = getRegister arg `thenUs` \ register -> + let + reg = if isFloatingRep pk then fDst else iDst + code = registerCode register reg + src = registerName register reg + pk = registerRep register + in + 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 + code . mkSeqInstr (OR src (RIReg src) iDst) + else code)) + + -- Once we have run out of argument registers, we move to the + -- stack... + + get_arg ([], offset) arg + = getRegister arg `thenUs` \ register -> + getNewRegNCG (registerRep register) + `thenUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + pk = registerRep register + sz = primRepToSize pk + in + returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +genCCall fn kind [StInt i] + | fn == SLIT ("PerformGC_wrapper") + = 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] + in + returnInstrs call + +genCCall fn kind args + = mapUs get_call_arg 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 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 + -- function names that begin with '.' are assumed to be special + -- internally generated names like '.mul,' which don't get an + -- underscore prefix + -- ToDo:needed (WDP 96/03) ??? + fn__2 = case (_HEAD_ fn) of + '.' -> ImmLit (uppPStr fn) + _ -> ImmLab (uppPStr fn) + + ------------ + get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code + + get_call_arg arg + = get_op arg `thenUs` \ (code, op, sz) -> + returnUs (code . mkSeqInstr (PUSH sz op)) + + ------------ + get_op + :: StixTree + -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size + + get_op (StInt i) + = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L) + + get_op (StInd pk mem) + = getAmode mem `thenUs` \ amode -> + let + code = amodeCode amode --asmVoid + addr = amodeAddr amode + sz = primRepToSize pk + in + returnUs (code, OpAddr addr, sz) + + get_op op + = getRegister op `thenUs` \ register -> + getNewRegNCG (registerRep register) + `thenUs` \ tmp -> + let + code = registerCode register tmp + reg = registerName register tmp + pk = registerRep register + sz = primRepToSize pk + in + returnUs (code, OpReg reg, sz) + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +genCCall fn kind args + = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args + `thenUs` \ ((unused,_), argCode) -> + let + nRegs = length allArgRegs - length unused + call = CALL fn__2 nRegs False + code = asmParThen (map ($ asmVoid) argCode) + in + returnSeq code [call, NOP] + where + -- function names that begin with '.' are assumed to be special + -- internally generated names like '.mul,' which don't get an + -- underscore prefix + -- ToDo:needed (WDP 96/03) ??? + fn__2 = case (_HEAD_ fn) of + '.' -> ImmLit (uppPStr fn) + _ -> ImmLab (uppPStr fn) + + ------------------------------------ + {- Try to get a value into a specific register (or registers) for + a call. The SPARC calling convention is an absolute + nightmare. The first 6x32 bits of arguments are mapped into + %o0 through %o5, and the remaining arguments are dumped to the + stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our + first argument is a pair of the list of remaining argument + registers to be assigned for this call and the next stack + offset to use for overflowing arguments. This way, + @get_arg@ can be applied to all of a call's arguments using + @mapAccumL@. + -} + get_arg + :: ([Reg],Int) -- Argument registers and stack offset (accumulator) + -> StixTree -- Current argument + -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code + + -- We have to use up all of our argument registers first... + + get_arg (dst:dsts, offset) arg + = getRegister arg `thenUs` \ register -> + getNewRegNCG (registerRep register) + `thenUs` \ tmp -> + let + reg = if isFloatingRep pk then tmp else dst + code = registerCode register reg + src = registerName register reg + pk = registerRep register + in + returnUs (case pk of + DoubleRep -> + case dsts of + [] -> (([], offset + 1), code . mkSeqInstrs [ + -- conveniently put the second part in the right stack + -- location, and load the first part into %o5 + 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, + LD W (spRel (-1)) dst__2]) + FloatRep -> ((dsts, offset), code . mkSeqInstrs [ + ST F src (spRel (-2)), + LD W (spRel (-2)) dst]) + _ -> ((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... + + get_arg ([], offset) arg + = getRegister arg `thenUs` \ register -> + getNewRegNCG (registerRep register) + `thenUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + pk = registerRep register + sz = primRepToSize pk + words = if pk == DoubleRep then 2 else 1 + in + returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset))) + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{Support bits} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers} +%* * +%************************************************************************ + +Turn those condition codes into integers now (when they appear on +the right hand side of an assignment). + +(If applicable) Do not fill the delay slots here; you will confuse the +register allocator. + +\begin{code} +condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register + +#if alpha_TARGET_ARCH +condIntReg = panic "MachCode.condIntReg (not on Alpha)" +condFltReg = panic "MachCode.condFltReg (not on Alpha)" +#endif {- alpha_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +condIntReg cond x y + = condIntCode cond x y `thenUs` \ condition -> + getNewRegNCG IntRep `thenUs` \ tmp -> + --getRegister dst `thenUs` \ register -> + let + --code2 = registerCode register tmp asmVoid + --dst__2 = registerName register tmp + 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 [ + SETCC cond (OpReg tmp), + AND L (OpImm (ImmInt 1)) (OpReg tmp), + MOV L (OpReg tmp) (OpReg dst)] + in + returnUs (Any IntRep code__2) + +condFltReg cond x y + = getUniqLabelNCG `thenUs` \ lbl1 -> + getUniqLabelNCG `thenUs` \ lbl2 -> + condFltCode cond x y `thenUs` \ condition -> + let + code = condCode condition + cond = condName condition + code__2 dst = code . mkSeqInstrs [ + 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 + returnUs (Any IntRep code__2) + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +condIntReg EQ x (StInt 0) + = getRegister 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 + returnUs (Any IntRep code__2) + +condIntReg EQ x y + = getRegister x `thenUs` \ register1 -> + getRegister 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 [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] + in + returnUs (Any IntRep code__2) + +condIntReg NE x (StInt 0) + = getRegister 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 + returnUs (Any IntRep code__2) + +condIntReg NE x y + = getRegister x `thenUs` \ register1 -> + getRegister 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 [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] + in + returnUs (Any IntRep code__2) + +condIntReg cond x y + = getUniqLabelNCG `thenUs` \ lbl1 -> + getUniqLabelNCG `thenUs` \ lbl2 -> + condIntCode cond x y `thenUs` \ condition -> + let + 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, + LABEL lbl1, + OR False g0 (RIImm (ImmInt 1)) dst, + LABEL lbl2] + in + returnUs (Any IntRep code__2) + +condFltReg cond x y + = getUniqLabelNCG `thenUs` \ lbl1 -> + getUniqLabelNCG `thenUs` \ lbl2 -> + condFltCode cond x y `thenUs` \ condition -> + let + code = condCode condition + cond = condName condition + code__2 dst = code . mkSeqInstrs [ + NOP, + BF cond False (ImmCLbl lbl1), NOP, + OR False g0 (RIImm (ImmInt 0)) dst, + BI ALWAYS False (ImmCLbl lbl2), NOP, + LABEL lbl1, + OR False g0 (RIImm (ImmInt 1)) dst, + LABEL lbl2] + in + returnUs (Any IntRep code__2) + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsubsection{@trivial*Code@: deal with trivial instructions} +%* * +%************************************************************************ + +Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary: +@trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look +for constants on the right hand side, because that's where the generic +optimizer will have put them. + +Similarly, for unary instructions, we don't have to worry about +matching an StInt as the argument, because genericOpt will already +have handled the constant-folding. + +\begin{code} +trivialCode + :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr) + ,IF_ARCH_i386 ((Operand -> Operand -> Instr) + ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr) + ,))) + -> StixTree -> StixTree -- the two arguments + -> UniqSM Register + +trivialFCode + :: PrimRep + -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr) + ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr) + ,IF_ARCH_i386 ( + {-this bizarre type for i386 seems a little too weird (WDP 96/03)-} + (Size -> Operand -> Instr) + -> (Size -> Operand -> Instr) {-reversed instr-} + -> Instr {-pop-} + -> Instr {-reversed instr: pop-} + ,))) + -> StixTree -> StixTree -- the two arguments + -> UniqSM Register + +trivialUCode + :: IF_ARCH_alpha((RI -> Reg -> Instr) + ,IF_ARCH_i386 ((Operand -> Instr) + ,IF_ARCH_sparc((RI -> Reg -> Instr) + ,))) + -> StixTree -- the one argument + -> UniqSM Register + +trivialUFCode + :: PrimRep + -> IF_ARCH_alpha((Reg -> Reg -> Instr) + ,IF_ARCH_i386 (Instr + ,IF_ARCH_sparc((Reg -> Reg -> Instr) + ,))) + -> StixTree -- the one argument + -> UniqSM Register + +#if alpha_TARGET_ARCH + +trivialCode instr x (StInt y) + | fits8Bits y + = getRegister 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 + returnUs (Any IntRep code__2) + +trivialCode instr x y + = getRegister x `thenUs` \ register1 -> + getRegister 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 (instr src1 (RIReg src2) dst) + in + returnUs (Any IntRep code__2) + +------------ +trivialUCode instr x + = getRegister 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 + returnUs (Any IntRep code__2) + +------------ +trivialFCode _ instr x y + = getRegister x `thenUs` \ register1 -> + getRegister y `thenUs` \ register2 -> + getNewRegNCG DoubleRep `thenUs` \ tmp1 -> + getNewRegNCG DoubleRep `thenUs` \ tmp2 -> + let + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 + + code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] . + mkSeqInstr (instr src1 src2 dst) + in + returnUs (Any DoubleRep code__2) + +trivialUFCode _ instr x + = getRegister 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 + returnUs (Any DoubleRep code__2) + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +trivialCode instr x y + | maybeToBool imm + = getRegister x `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 + mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)] + in + returnUs (Any IntRep code__2) + where + imm = maybeImm y + imm__2 = case imm of Just x -> x + +trivialCode instr x y + | maybeToBool imm + = getRegister 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)) + in + returnUs (Any IntRep code__2) + where + imm = maybeImm x + imm__2 = case imm of Just x -> x + +trivialCode instr x (StInd pk mem) + = getRegister 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)) + in + returnUs (Any pk code__2) + +trivialCode instr (StInd pk mem) y + = getRegister 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 + 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 + returnUs (Any pk code__2) + +trivialCode instr x y + = getRegister x `thenUs` \ register1 -> + getRegister y `thenUs` \ register2 -> + --getNewRegNCG IntRep `thenUs` \ tmp1 -> + getNewRegNCG IntRep `thenUs` \ tmp2 -> + let + fixedname = registerName register1 eax + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + 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 + returnUs (Any IntRep code__2) + +----------- +trivialUCode instr x + = getRegister 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)) + in + returnUs (Any IntRep code__2) + +----------- +trivialFCode pk _ instrr _ _ (StInd pk' mem) y + = getRegister y `thenUs` \ register2 -> + --getNewRegNCG (registerRep register2) + -- `thenUs` \ tmp2 -> + getAmode mem `thenUs` \ amode -> + let + code1 = amodeCode amode + src1 = amodeAddr amode + + code__2 dst = let + code2 = registerCode register2 dst + src2 = registerName register2 dst + in asmParThen [code1 asmVoid,code2 asmVoid] . + mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)] + in + returnUs (Any pk code__2) + +trivialFCode pk instr _ _ _ x (StInd pk' mem) + = getRegister x `thenUs` \ register1 -> + --getNewRegNCG (registerRep register1) + -- `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] . + mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)] + in + returnUs (Any pk code__2) + +trivialFCode pk _ _ _ instrpr x y + = getRegister x `thenUs` \ register1 -> + getRegister y `thenUs` \ register2 -> + --getNewRegNCG (registerRep register1) + -- `thenUs` \ tmp1 -> + --getNewRegNCG (registerRep register2) + -- `thenUs` \ tmp2 -> + getNewRegNCG DoubleRep `thenUs` \ tmp -> + let + pk1 = registerRep register1 + code1 = registerCode register1 st0 --tmp1 + src1 = registerName register1 st0 --tmp1 + + pk2 = registerRep register2 + + code__2 dst = let + code2 = registerCode register2 dst + src2 = registerName register2 dst + in asmParThen [code1 asmVoid, code2 asmVoid] . + mkSeqInstr instrpr + in + returnUs (Any pk1 code__2) + +------------- +trivialUFCode pk instr (StInd pk' mem) + = getAmode mem `thenUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src), + instr] + in + returnUs (Any pk code__2) + +trivialUFCode pk instr x + = getRegister 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 + returnUs (Any pk code__2) + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +trivialCode instr x (StInt y) + | fits13Bits y + = getRegister 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 + returnUs (Any IntRep code__2) + +trivialCode instr x y + = getRegister x `thenUs` \ register1 -> + getRegister 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 (instr src1 (RIReg src2) dst) + in + returnUs (Any IntRep code__2) + +------------ +trivialFCode pk instr x y + = getRegister x `thenUs` \ register1 -> + getRegister y `thenUs` \ register2 -> + getNewRegNCG (registerRep register1) + `thenUs` \ tmp1 -> + getNewRegNCG (registerRep register2) + `thenUs` \ tmp2 -> + getNewRegNCG DoubleRep `thenUs` \ tmp -> + let + promote x = asmInstr (FxTOy F DF x tmp) + + pk1 = registerRep register1 + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + pk2 = registerRep register2 + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 + + code__2 dst = + if pk1 == pk2 then + asmParThen [code1 asmVoid, code2 asmVoid] . + mkSeqInstr (instr (primRepToSize pk) src1 src2 dst) + 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 + returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) + +------------ +trivialUCode instr x + = getRegister 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 + returnUs (Any IntRep code__2) + +------------- +trivialUFCode pk instr x + = getRegister 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 + returnUs (Any pk code__2) + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsubsection{Coercing to/from integer/floating-point...} +%* * +%************************************************************************ + +@coerce(Int|Flt)Code@ are simple coercions that don't require any code +to be generated. Here we just change the type on the Register passed +on up. The code is machine-independent. + +@coerce(Int2FP|FP2Int)@ are more complicated integer/float +conversions. We have to store temporaries in memory to move +between the integer and the floating point register sets. + +\begin{code} +coerceIntCode :: PrimRep -> StixTree -> UniqSM Register +coerceFltCode :: StixTree -> UniqSM Register + +coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register +coerceFP2Int :: StixTree -> UniqSM Register + +coerceIntCode pk x + = getRegister x `thenUs` \ register -> + returnUs ( + case register of + Fixed _ reg code -> Fixed pk reg code + Any _ code -> Any pk code + ) + +------------- +coerceFltCode x + = getRegister x `thenUs` \ register -> + returnUs ( + case register of + Fixed _ reg code -> Fixed DoubleRep reg code + Any _ code -> Any DoubleRep code + ) +\end{code} + +\begin{code} +#if alpha_TARGET_ARCH + +coerceInt2FP _ x + = getRegister x `thenUs` \ register -> + getNewRegNCG IntRep `thenUs` \ reg -> + let + code = registerCode register reg + src = registerName register reg + + code__2 dst = code . mkSeqInstrs [ + ST Q src (spRel 0), + LD TF dst (spRel 0), + CVTxy Q TF dst dst] + in + returnUs (Any DoubleRep code__2) + +------------- +coerceFP2Int x + = getRegister x `thenUs` \ register -> + getNewRegNCG DoubleRep `thenUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + + code__2 dst = code . mkSeqInstrs [ + CVTxy TF Q src tmp, + ST TF tmp (spRel 0), + LD Q dst (spRel 0)] + in + returnUs (Any IntRep code__2) + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +coerceInt2FP pk x + = getRegister 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 + MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), + FILD (primRepToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] + in + returnUs (Any pk code__2) + +------------ +coerceFP2Int x + = getRegister x `thenUs` \ register -> + getNewRegNCG DoubleRep `thenUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + pk = registerRep register + + 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 + returnUs (Any IntRep code__2) + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +coerceInt2FP pk x + = getRegister x `thenUs` \ register -> + getNewRegNCG IntRep `thenUs` \ reg -> + let + code = registerCode register reg + src = registerName register reg + + code__2 dst = code . mkSeqInstrs [ + ST W src (spRel (-2)), + LD W (spRel (-2)) dst, + FxTOy W (primRepToSize pk) dst dst] + in + returnUs (Any pk code__2) + +------------ +coerceFP2Int x + = getRegister x `thenUs` \ register -> + getNewRegNCG IntRep `thenUs` \ reg -> + getNewRegNCG FloatRep `thenUs` \ tmp -> + let + code = registerCode register reg + src = registerName register reg + pk = registerRep register + + code__2 dst = code . mkSeqInstrs [ + FxTOy (primRepToSize pk) W src tmp, + ST W tmp (spRel (-2)), + LD W (spRel (-2)) dst] + in + returnUs (Any IntRep code__2) + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsubsection{Coercing integer to @Char@...} +%* * +%************************************************************************ + +Integer to character conversion. Where applicable, we try to do this +in one step if the original object is in memory. + +\begin{code} +chrCode :: StixTree -> UniqSM Register + +#if alpha_TARGET_ARCH + +chrCode x + = getRegister 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 + returnUs (Any IntRep code__2) + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +chrCode x + = getRegister 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 + returnUs (Any IntRep code__2) + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +chrCode (StInd pk mem) + = getAmode mem `thenUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + src_off = addrOffset src 3 + src__2 = case src_off of Just x -> x + code__2 dst = if maybeToBool src_off then + code . mkSeqInstr (LD BU src__2 dst) + else + code . mkSeqInstrs [ + LD (primRepToSize pk) src dst, + AND False dst (RIImm (ImmInt 255)) dst] + in + returnUs (Any pk code__2) + +chrCode x + = getRegister 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 + returnUs (Any IntRep code__2) + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsubsection{Absolute value on integers} +%* * +%************************************************************************ + +Absolute value on integers, mostly for gmp size check macros. Again, +the argument cannot be an StInt, because genericOpt already folded +constants. + +If applicable, do not fill the delay slots here; you will confuse the +register allocator. + +\begin{code} +absIntCode :: StixTree -> UniqSM Register + +#if alpha_TARGET_ARCH +absIntCode = panic "MachCode.absIntCode: not on Alphas" +#endif {- alpha_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +absIntCode x + = getRegister 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 + returnUs (Any IntRep code__2) + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +absIntCode x + = getRegister 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] + in + returnUs (Any IntRep code__2) + +#endif {- sparc_TARGET_ARCH -} +\end{code} diff --git a/ghc/compiler/nativeGen/MachDesc.lhs b/ghc/compiler/nativeGen/MachDesc.lhs deleted file mode 100644 index c89d228..0000000 --- a/ghc/compiler/nativeGen/MachDesc.lhs +++ /dev/null @@ -1,95 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1995 -% - -Machine- and flag- specific bits that the abstract code generator has -to know about. - -No doubt there will be more... - -\begin{code} -#include "HsVersions.h" - -module MachDesc ( - Target(..){-(..) for target_STRICT only-}, mkTarget, RegLoc(..), - - saveLoc, - - fixedHeaderSize, varHeaderSize, stgReg, - sizeof, volatileSaves, volatileRestores, hpRel, - amodeToStix, amodeToStix', charLikeClosureSize, - intLikeClosureSize, mutHS, dataHS, primToStix, macroCode, - heapCheck - - -- and, for self-sufficiency... - ) where - -import AbsCSyn -import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) ) -import Outputable -import OrdList ( OrdList ) -import SMRep ( SMRep ) -import Stix -import UniqSupply -import Unique -import Unpretty ( PprStyle, CSeq ) -import Util - -data RegLoc = Save StixTree | Always StixTree -\end{code} - -Think of this as a big runtime class dictionary: -\begin{code} -data Target = Target - Int -- fixedHeaderSize - (SMRep -> Int) -- varHeaderSize - (MagicId -> RegLoc) -- stgReg - (PrimRep -> Int) -- sizeof - (HeapOffset -> Int) -- hpRel - (CAddrMode -> StixTree) -- amodeToStix - (CAddrMode -> StixTree) -- amodeToStix' - ( - ([MagicId] -> [StixTree]), -- volatileSaves - ([MagicId] -> [StixTree]), -- volatileRestores - Int, -- charLikeClosureSize - Int, -- intLikeClosureSize - StixTree, -- mutHS - StixTree, -- dataHS - ([CAddrMode] -> PrimOp -> [CAddrMode] -> UniqSM StixTreeList), - -- primToStix - (CStmtMacro -> [CAddrMode] -> UniqSM StixTreeList), - -- macroCode - (StixTree -> StixTree -> StixTree -> UniqSM StixTreeList) - -- heapCheck - ) - -mkTarget = Target - -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 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 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 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} -\end{code} - diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs new file mode 100644 index 0000000..add0ada --- /dev/null +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -0,0 +1,676 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1996 +% +\section[MachMisc]{Description of various machine-specific things} + +\begin{code} +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +module MachMisc ( + + fixedHdrSizeInWords, varHdrSizeInWords, + charLikeSize, intLikeSize, mutHS, dataHS, + sizeOf, primRepToSize, + + eXTRA_STK_ARGS_HERE, + + volatileSaves, volatileRestores, + + storageMgrInfo, smCAFlist, smOldLim, smOldMutables, + smStablePtrTable, + + targetMaxDouble, targetMaxInt, targetMinDouble, targetMinInt, + + underscorePrefix, + fmtAsmLbl, + cvtLitLit, + exactLog2, + + Instr(..), IF_ARCH_i386(Operand(..) COMMA,) + Cond(..), + Size(..) + +#if alpha_TARGET_ARCH + , RI(..) +#endif +#if i386_TARGET_ARCH +#endif +#if sparc_TARGET_ARCH + , RI(..), riZero +#endif + ) where + +import Ubiq{-uitous-} +import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia +import NcgLoop ( underscorePrefix, fmtAsmLbl ) -- paranoia + +import AbsCSyn ( MagicId(..) ) +import AbsCUtils ( magicIdPrimRep ) +import CmdLineOpts ( opt_SccProfilingOn ) +import Literal ( mkMachInt, Literal(..) ) +import MachRegs ( stgReg, callerSaves, RegLoc(..), + Imm(..), Reg(..), Addr + ) +import OrdList ( OrdList ) +import PrimRep ( PrimRep(..) ) +import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) +import Stix ( StixTree(..), StixReg(..), sStLitLbl, + CodeSegment + ) +import Util ( panic ) +\end{code} + +\begin{code} +underscorePrefix :: Bool -- leading underscore on labels? + +underscorePrefix + = IF_ARCH_alpha(False + ,{-else-} IF_ARCH_i386( + IF_OS_linuxaout(True + , IF_OS_freebsd(True + , IF_OS_bsdi(True + , {-otherwise-} False))) + ,{-else-}IF_ARCH_sparc( + IF_OS_sunos4(True, {-otherwise-} False) + ,))) + +--------------------------- +fmtAsmLbl :: String -> String -- for formatting labels + +fmtAsmLbl s + = IF_ARCH_alpha( + {- The alpha assembler likes temporary labels to look like $L123 + instead of L123. (Don't toss the L, because then Lf28 + turns into $f28.) + -} + '$' : s + ,{-otherwise-} + s + ) + +--------------------------- +cvtLitLit :: String -> String + +-- ToDo: some kind of *careful* attention needed... + +cvtLitLit "stdin" = IF_ARCH_alpha("_iob+0" {-probably OK...-} + ,IF_ARCH_i386("_IO_stdin_" + ,IF_ARCH_sparc("__iob+0x0"{-probably OK...-} + ,))) +cvtLitLit "stdout" = IF_ARCH_alpha("_iob+56"{-dodgy *at best*...-} + ,IF_ARCH_i386("_IO_stdout_" + ,IF_ARCH_sparc("__iob+0x14"{-dodgy *at best*...-} + ,))) +cvtLitLit "stderr" = IF_ARCH_alpha("_iob+112"{-dodgy *at best*...-} + ,IF_ARCH_i386("_IO_stderr_" + ,IF_ARCH_sparc("__iob+0x28"{-dodgy *at best*...-} + ,))) +cvtLitLit s + | isHex s = s + | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''") + where + isHex ('0':'x':xs) = all isHexDigit xs + isHex _ = False + -- Now, where have I seen this before? + isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' +\end{code} + +% ---------------------------------------------------------------- + +We (allegedly) put the first six C-call arguments in registers; +where do we start putting the rest of them? +\begin{code} +eXTRA_STK_ARGS_HERE :: Int +eXTRA_STK_ARGS_HERE + = IF_ARCH_alpha(0, IF_ARCH_i386(23{-6x4bytes-}, IF_ARCH_sparc(23,???))) +\end{code} + +% ---------------------------------------------------------------- + +@fixedHdrSizeInWords@ and @varHdrSizeInWords@: these are not dependent +on target architecture. +\begin{code} +fixedHdrSizeInWords :: Int + +fixedHdrSizeInWords + = 1{-info ptr-} + profFHS + parFHS + tickyFHS + -- obviously, we aren't taking non-sequential too seriously yet + where + profFHS = if opt_SccProfilingOn then 1 else 0 + parFHS = {-if PAR or GRAN then 1 else-} 0 + tickyFHS = {-if ticky ... then 1 else-} 0 + +varHdrSizeInWords :: SMRep -> Int{-in words-} + +varHdrSizeInWords sm + = case sm of + StaticRep _ _ -> 0 + SpecialisedRep _ _ _ _ -> 0 + GenericRep _ _ _ -> 0 + BigTupleRep _ -> 1 + MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -} + DataRep _ -> 1 + DynamicRep -> 2 + BlackHoleRep -> 0 + PhantomRep -> panic "MachMisc.varHdrSizeInWords:phantom" +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +Static closure sizes: +\begin{code} +charLikeSize, intLikeSize :: Int + +charLikeSize = blahLikeSize CharLikeRep +intLikeSize = blahLikeSize IntLikeRep + +blahLikeSize blah + = fromInteger (sizeOf PtrRep) + * (fixedHdrSizeInWords + varHdrSizeInWords blahLikeRep + 1) + where + blahLikeRep = SpecialisedRep blah 0 1 SMNormalForm + +-------- +mutHS, dataHS :: StixTree + +mutHS = blah_hs (MuTupleRep 0) +dataHS = blah_hs (DataRep 0) + +blah_hs blah + = StInt (toInteger words) + where + words = fixedHdrSizeInWords + varHdrSizeInWords blah +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +Size of a @PrimRep@, in bytes. + +\begin{code} +sizeOf :: PrimRep -> Integer{-in bytes-} + -- the result is an Integer only because it's more convenient + +sizeOf pr = case (primRepToSize pr) of + IF_ARCH_alpha({B -> 1; BU -> 1; {-W -> 2; WU -> 2; L -> 4; SF -> 4;-} _ -> 8},) + IF_ARCH_sparc({B -> 1; BU -> 1; {-HW -> 2; HWU -> 2;-} W -> 4; {-D -> 8;-} F -> 4; DF -> 8},) + IF_ARCH_i386( {B -> 1; {-S -> 2;-} L -> 4; F -> 4; DF -> 8 },) +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +Now the volatile saves and restores. We add the basic guys to the +list of ``user'' registers provided. Note that there are more basic +registers on the restore list, because some are reloaded from +constants. + +(@volatileRestores@ used only for wrapper-hungry PrimOps.) + +\begin{code} +volatileSaves, volatileRestores :: [MagicId] -> [StixTree] + +save_cands = [BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg] +restore_cands = save_cands ++ [StkStubReg,StdUpdRetVecReg] + +volatileSaves vols + = map save ((filter callerSaves) (save_cands ++ vols)) + where + save x = StAssign (magicIdPrimRep x) loc reg + where + reg = StReg (StixMagicId x) + loc = case stgReg x of + Save loc -> loc + Always _ -> panic "volatileSaves" + +volatileRestores vols + = map restore ((filter callerSaves) (restore_cands ++ vols)) + where + restore x = StAssign (magicIdPrimRep x) reg loc + where + reg = StReg (StixMagicId x) + loc = case stgReg x of + Save loc -> loc + Always _ -> panic "volatileRestores" +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +Obviously slightly weedy +(Note that the floating point values aren't terribly important.) +ToDo: Fix!(JSM) +\begin{code} +targetMinDouble = MachDouble (-1.7976931348623157e+308) +targetMaxDouble = MachDouble (1.7976931348623157e+308) +targetMinInt = mkMachInt (-2147483647) +targetMaxInt = mkMachInt 2147483647 +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +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 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 PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE)) +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +This algorithm for determining the $\log_2$ of exact powers of 2 comes +from GCC. It requires bit manipulation primitives, and we use GHC +extensions. Tough. + +\begin{code} +w2i x = word2Int# x +i2w x = int2Word# x +i2w_s x = (x::Int#) + +exactLog2 :: Integer -> Maybe Integer +exactLog2 x + = if (x <= 0 || x >= 2147483648) then + Nothing + else + case (fromInteger x) of { I# x# -> + if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then + Nothing + else + Just (toInteger (I# (pow2 x#))) + } + where + shiftr x y = shiftRA# x y + + pow2 x# | x# ==# 1# = 0# + | otherwise = 1# +# pow2 (w2i (i2w x# `shiftr` i2w_s 1#)) +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +\begin{code} +data Cond +#if alpha_TARGET_ARCH + = ALWAYS -- For BI (same as BR) + | EQ -- For CMP and BI + | GE -- For BI only + | GT -- For BI only + | LE -- For CMP and BI + | LT -- For CMP and BI + | NE -- For BI only + | NEVER -- For BI (null instruction) + | ULE -- For CMP only + | ULT -- For CMP only +#endif +#if i386_TARGET_ARCH + = ALWAYS -- What's really used? ToDo + | EQ + | GE + | GEU + | GT + | GU + | LE + | LEU + | LT + | LU + | NE + | NEG + | POS +#endif +#if sparc_TARGET_ARCH + = ALWAYS -- What's really used? ToDo + | EQ + | GE + | GEU + | GT + | GU + | LE + | LEU + | LT + | LU + | NE + | NEG + | NEVER + | POS + | VC + | VS +#endif +\end{code} + +\begin{code} +data Size +#if alpha_TARGET_ARCH + = B -- byte + | BU +-- | W -- word (2 bytes): UNUSED +-- | WU -- : UNUSED +-- | L -- longword (4 bytes): UNUSED + | Q -- quadword (8 bytes) +-- | FF -- VAX F-style floating pt: UNUSED +-- | GF -- VAX G-style floating pt: UNUSED +-- | DF -- VAX D-style floating pt: UNUSED +-- | SF -- IEEE single-precision floating pt: UNUSED + | TF -- IEEE double-precision floating pt +#endif +#if i386_TARGET_ARCH + = B -- byte (lower) +-- | HB -- higher byte **UNUSED** +-- | S -- : UNUSED + | L + | F -- IEEE single-precision floating pt + | DF -- IEEE single-precision floating pt +#endif +#if sparc_TARGET_ARCH + = B -- byte (signed) + | BU -- byte (unsigned) +-- | HW -- halfword, 2 bytes (signed): UNUSED +-- | HWU -- halfword, 2 bytes (unsigned): UNUSED + | W -- word, 4 bytes +-- | D -- doubleword, 8 bytes: UNUSED + | F -- IEEE single-precision floating pt + | DF -- IEEE single-precision floating pt +#endif + +primRepToSize :: PrimRep -> Size + +primRepToSize PtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize CodePtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize DataPtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize RetRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize CostCentreRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize CharRep = IF_ARCH_alpha( BU, IF_ARCH_i386( L, IF_ARCH_sparc( BU,))) +primRepToSize IntRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize WordRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize AddrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize FloatRep = IF_ARCH_alpha( TF, IF_ARCH_i386( F, IF_ARCH_sparc( F ,))) +primRepToSize DoubleRep = IF_ARCH_alpha( TF, IF_ARCH_i386( DF,IF_ARCH_sparc( DF,))) +primRepToSize ArrayRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize ByteArrayRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize StablePtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +primRepToSize MallocPtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) +\end{code} + +%************************************************************************ +%* * +\subsection{Machine's assembly language} +%* * +%************************************************************************ + +We have a few common ``instructions'' (nearly all the pseudo-ops) but +mostly all of @Instr@ is machine-specific. + +\begin{code} +data Instr + = COMMENT FAST_STRING -- comment pseudo-op + | SEGMENT CodeSegment -- {data,text} segment pseudo-op + | LABEL CLabel -- global label pseudo-op + | ASCII Bool -- True <=> needs backslash conversion + String -- the literal string + | DATA Size + [Imm] +\end{code} + +\begin{code} +#if alpha_TARGET_ARCH + +-- data Instr continues... + +-- Loads and stores. + + | LD Size Reg Addr -- size, dst, src + | LDA Reg Addr -- dst, src + | LDAH Reg Addr -- dst, src + | LDGP Reg Addr -- dst, src + | LDI Size Reg Imm -- size, dst, src + | ST Size Reg Addr -- size, src, dst + +-- Int Arithmetic. + + | CLR Reg -- dst + | ABS Size RI Reg -- size, src, dst + | NEG Size Bool RI Reg -- size, overflow, src, dst + | ADD Size Bool Reg RI Reg -- size, overflow, src, src, dst + | SADD Size Size Reg RI Reg -- size, scale, src, src, dst + | SUB Size Bool Reg RI Reg -- size, overflow, src, src, dst + | SSUB Size Size Reg RI Reg -- size, scale, src, src, dst + | MUL Size Bool Reg RI Reg -- size, overflow, src, src, dst + | DIV Size Bool Reg RI Reg -- size, unsigned, src, src, dst + | REM Size Bool Reg RI Reg -- size, unsigned, src, src, dst + +-- Simple bit-twiddling. + + | 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 + +-- Comparison + + | CMP Cond Reg RI Reg + +-- Float Arithmetic. + + | 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 + +-- Jumping around. + + | BI Cond Reg Imm + | BF Cond Reg Imm + | BR Imm + | JMP Reg Addr Int + | BSR Imm Int + | JSR Reg Addr Int + +-- Alpha-specific pseudo-ops. + + | FUNBEGIN CLabel + | FUNEND CLabel + +data RI + = RIReg Reg + | RIImm Imm + +#endif {- alpha_TARGET_ARCH -} +\end{code} + +\begin{code} +#if i386_TARGET_ARCH + +-- data Instr continues... + +-- Moves. + + | 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 + +-- Int Arithmetic. + + | ADD Size Operand Operand + | SUB Size Operand Operand + +-- Multiplication (signed and unsigned), Division (signed and unsigned), +-- result in %eax, %edx. + + | IMUL Size Operand Operand + | IDIV Size Operand + +-- Simple bit-twiddling. + + | 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 + +-- Float Arithmetic. -- ToDo for 386 + +-- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions +-- right up until we spit them out. + + | SAHF -- stores ah into flags + | FABS + | FADD Size Operand -- src + | FADDP + | FIADD Size Addr -- src + | FCHS + | FCOM Size Operand -- src + | FCOS + | FDIV Size Operand -- src + | FDIVP + | FIDIV Size Addr -- src + | FDIVR Size Operand -- src + | 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 + | FMUL Size Operand -- src + | FMULP + | FIMUL Size Addr -- src + | FRNDINT + | FSIN + | FSQRT + | FST Size Operand -- dst + | FSTP Size Operand -- dst + | FSUB Size Operand -- src + | FSUBP + | FISUB Size Addr -- src + | FSUBR Size Operand -- src + | FSUBRP + | FISUBR Size Addr -- src + | FTST + | FCOMP Size Operand -- src + | FUCOMPP + | FXCH + | FNSTSW + | FNOP + +-- Comparison + + | TEST Size Operand Operand + | CMP Size Operand Operand + | SETCC Cond Operand + +-- Stack Operations. + + | PUSH Size Operand + | POP Size Operand + +-- Jumping around. + + | JMP Operand -- target + | JXX Cond CLabel -- target + | CALL Imm + +-- Other things. + + | CLTD -- sign extend %eax into %edx:%eax + +data Operand + = OpReg Reg -- register + | OpImm Imm -- immediate value + | OpAddr Addr -- memory reference + +#endif {- i386_TARGET_ARCH -} +\end{code} + +\begin{code} +#if sparc_TARGET_ARCH + +-- data Instr continues... + +-- Loads and stores. + + | LD Size Addr Reg -- size, src, dst + | ST Size Reg Addr -- size, src, dst + +-- Int Arithmetic. + + | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + +-- Simple bit-twiddling. + + | AND Bool Reg RI Reg -- cc?, src1, src2, dst + | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst + | OR Bool Reg RI Reg -- cc?, src1, src2, dst + | ORN Bool Reg RI Reg -- cc?, src1, src2, dst + | XOR Bool Reg RI Reg -- cc?, src1, src2, dst + | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst + | SLL Reg RI Reg -- src1, src2, dst + | SRL Reg RI Reg -- src1, src2, dst + | SRA Reg RI Reg -- src1, src2, dst + | SETHI Imm Reg -- src, dst + | NOP -- Really SETHI 0, %g0, but worth an alias + +-- Float Arithmetic. + +-- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions +-- right up until we spit them out. + + | FABS Size Reg Reg -- src dst + | FADD Size Reg Reg Reg -- src1, src2, dst + | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst + | FDIV Size Reg Reg Reg -- src1, src2, dst + | FMOV Size Reg Reg -- src, dst + | FMUL Size Reg Reg Reg -- src1, src2, dst + | FNEG Size Reg Reg -- src, dst + | FSQRT Size Reg Reg -- src, dst + | FSUB Size Reg Reg Reg -- src1, src2, dst + | FxTOy Size Size Reg Reg -- src, dst + +-- Jumping around. + + | BI Cond Bool Imm -- cond, annul?, target + | BF Cond Bool Imm -- cond, annul?, target + + | JMP Addr -- target + | CALL Imm Int Bool -- target, args, terminal + +data RI = RIReg Reg + | RIImm Imm + +riZero :: RI -> Bool + +riZero (RIImm (ImmInt 0)) = True +riZero (RIImm (ImmInteger 0)) = True +riZero (RIReg (FixedReg ILIT(0))) = True +riZero _ = False + +#endif {- sparc_TARGET_ARCH -} +\end{code} diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs new file mode 100644 index 0000000..b122217 --- /dev/null +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -0,0 +1,1022 @@ +% +% (c) The AQUA Project, Glasgow University, 1996 +% +\section[MachRegs]{Machine-specific info about registers} + +Also includes stuff about immediate operands, which are +often/usually quite entangled with registers. + +(Immediates could be untangled from registers at some cost in tangled +modules --- the pleasure has been foregone.) + +\begin{code} +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +module MachRegs ( + + Reg(..), + Imm(..), + Addr(..), + RegLoc(..), + RegNo(..), + + addrOffset, + argRegs, + baseRegOffset, + callClobberedRegs, + callerSaves, + dblImmLit, + extractMappedRegNos, + freeMappedRegs, + freeReg, freeRegs, + getNewRegNCG, + magicIdRegMaybe, + mkReg, + realReg, + reservedRegs, + saveLoc, + spRel, + stgReg, + strImmLit + +#if alpha_TARGET_ARCH + , allArgRegs + , fits8Bits + , fReg + , gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zero +#endif +#if i386_TARGET_ARCH + , eax, ebx, ecx, edx, esi, esp + , st0, st1, st2, st3, st4, st5, st6, st7 +#endif +#if sparc_TARGET_ARCH + , allArgRegs + , fits13Bits + , fPair, fpRel, gReg, iReg, lReg, oReg, largeOffsetError + , fp, g0, o0, f0 + +#endif + ) where + +import Ubiq{-uitous-} + +import AbsCSyn ( MagicId(..) ) +import AbsCUtils ( magicIdPrimRep ) +import Pretty ( ppStr, ppRational, ppShow ) +import PrimOp ( PrimOp(..) ) +import PrimRep ( PrimRep(..) ) +import Stix ( sStLitLbl, StixTree(..), StixReg(..), + CodeSegment + ) +import Unique ( Unique{-instance Ord3-} ) +import UniqSupply ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, + getUnique, returnUs, thenUs, UniqSM(..) + ) +import Unpretty ( uppStr, Unpretty(..) ) +import Util ( panic ) +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +\begin{code} +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLab Unpretty -- Simple string label (underscore-able) + | ImmLit Unpretty -- Simple string + IF_ARCH_sparc( + | LO Imm -- Possible restrictions... + | HI Imm + ,) + +strImmLit s = ImmLit (uppStr s) +dblImmLit r + = strImmLit ( + IF_ARCH_alpha({-prepend nothing-} + ,IF_ARCH_i386( '0' : 'd' : + ,IF_ARCH_sparc('0' : 'r' :,))) + ppShow 80 (ppRational r)) +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +\begin{code} +data Addr +#if alpha_TARGET_ARCH + = AddrImm Imm + | AddrReg Reg + | AddrRegImm Reg Imm +#endif + +#if i386_TARGET_ARCH + = Addr Base Index Displacement + | ImmAddr Imm Int + +type Base = Maybe Reg +type Index = Maybe (Reg, Int) -- Int is 2, 4 or 8 +type Displacement = Imm +#endif + +#if sparc_TARGET_ARCH + = AddrRegReg Reg Reg + | AddrRegImm Reg Imm +#endif + +addrOffset :: Addr -> Int -> Maybe Addr + +addrOffset addr off + = case addr of +#if alpha_TARGET_ARCH + _ -> panic "MachMisc.addrOffset not defined for Alpha" +#endif +#if i386_TARGET_ARCH + ImmAddr i off0 -> Just (ImmAddr i (off0 + off)) + Addr r i (ImmInt n) -> Just (Addr r i (ImmInt (n + off))) + Addr r i (ImmInteger n) + -> Just (Addr r i (ImmInt (fromInteger (n + toInteger off)))) + _ -> Nothing +#endif +#if sparc_TARGET_ARCH + AddrRegImm r (ImmInt n) + | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2)) + | otherwise -> Nothing + where n2 = n + off + + AddrRegImm r (ImmInteger n) + | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) + | otherwise -> Nothing + where n2 = n + toInteger off + + AddrRegReg r (FixedReg ILIT(0)) + | fits13Bits off -> Just (AddrRegImm r (ImmInt off)) + | otherwise -> Nothing + + _ -> Nothing + +#endif {-sparc-} + +----------------- +#if alpha_TARGET_ARCH + +fits8Bits :: Integer -> Bool +fits8Bits i = i >= -256 && i < 256 + +#endif + +#if sparc_TARGET_ARCH +{-# SPECIALIZE + fits13Bits :: Int -> Bool + #-} +{-# SPECIALIZE + fits13Bits :: Integer -> Bool + #-} + +fits13Bits :: Integral a => a -> Bool +fits13Bits x = x >= -4096 && x < 4096 + +----------------- +largeOffsetError i + = error ("ERROR: SPARC native-code generator cannot handle large offset ("++show i++");\nprobably because of large constant data structures;\nworkaround: use -fvia-C on this module.\n") + +#endif {-sparc-} +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +@stgReg@: we map STG registers onto appropriate Stix Trees. First, we +handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@. +The rest are either in real machine registers or stored as offsets +from BaseReg. + +\begin{code} +data RegLoc = Save StixTree | Always StixTree +\end{code} + +Trees for register save locations: +\begin{code} +saveLoc :: MagicId -> StixTree + +saveLoc reg = case (stgReg reg) of {Always loc -> loc; Save loc -> loc} +\end{code} + +\begin{code} +stgReg :: MagicId -> RegLoc + +stgReg x + = case (magicIdRegMaybe x) of + Just _ -> Save nonReg + Nothing -> Always nonReg + where + offset = baseRegOffset x + + baseLoc = case (magicIdRegMaybe BaseReg) of + Just _ -> StReg (StixMagicId BaseReg) + Nothing -> sStLitLbl SLIT("MainRegTable") + + nonReg = case x of + StkStubReg -> sStLitLbl SLIT("STK_STUB_closure") + StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame") + BaseReg -> sStLitLbl SLIT("MainRegTable") + -- these Hp&HpLim cases perhaps should + -- not be here for i386 (???) WDP 96/03 + Hp -> StInd PtrRep (sStLitLbl SLIT("StorageMgrInfo")) + HpLim -> StInd PtrRep (sStLitLbl + (_PK_ ("StorageMgrInfo+" ++ BYTES_PER_WORD_STR))) + TagReg -> StInd IntRep (StPrim IntSubOp [infoptr, + StInt (1*BYTES_PER_WORD)]) + where + r2 = VanillaReg PtrRep ILIT(2) + infoptr = case (stgReg r2) of + Always t -> t + Save _ -> StReg (StixMagicId r2) + _ -> StInd (magicIdPrimRep x) + (StPrim IntAddOp [baseLoc, + StInt (toInteger (offset*BYTES_PER_WORD))]) +\end{code} + +% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +@spRel@ gives us a stack relative addressing mode for volatile +temporaries and for excess call arguments. @fpRel@, where +applicable, is the same but for the frame pointer. + +\begin{code} +spRel :: Int -- desired stack offset in words, positive or negative + -> Addr + +spRel n +#if i386_TARGET_ARCH + = Addr (Just esp) Nothing (ImmInt (n * BYTES_PER_WORD)) +#else + = AddrRegImm sp (ImmInt (n * BYTES_PER_WORD)) +#endif + +#if sparc_TARGET_ARCH +fpRel :: Int -> Addr + -- Duznae work for offsets greater than 13 bits; we just hope for + -- the best +fpRel n + = AddrRegImm fp (ImmInt (n * BYTES_PER_WORD)) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Reg]{Real registers} +%* * +%************************************************************************ + +Static Registers correspond to actual machine registers. These should +be avoided until the last possible moment. + +Dynamic registers are allocated on the fly, usually to represent a single +value in the abstract assembly code (i.e. dynamic registers are usually +single assignment). Ultimately, they are mapped to available machine +registers before spitting out the code. + +\begin{code} +data Reg + = FixedReg FAST_INT -- A pre-allocated machine register + + | MappedReg FAST_INT -- A dynamically allocated machine register + + | MemoryReg Int PrimRep -- A machine "register" actually held in + -- a memory allocated table of + -- registers which didn't fit in real + -- registers. + + | UnmappedReg Unique PrimRep -- One of an infinite supply of registers, + -- always mapped to one of the earlier + -- two (?) before we're done. + +mkReg :: Unique -> PrimRep -> Reg +mkReg = UnmappedReg + +getNewRegNCG :: PrimRep -> UniqSM Reg +getNewRegNCG pk + = getUnique `thenUs` \ u -> + returnUs (UnmappedReg u pk) + +instance Text Reg where + showsPrec _ (FixedReg i) = showString "%" . shows IBOX(i) + showsPrec _ (MappedReg i) = showString "%" . shows IBOX(i) + showsPrec _ (MemoryReg i _) = showString "%M" . shows i + showsPrec _ (UnmappedReg i _) = showString "%U" . shows i + +#ifdef DEBUG +instance Outputable Reg where + ppr sty r = ppStr (show r) +#endif + +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' _) = cmp u u' +cmpReg r1 r2 + = let tag1 = tagReg r1 + tag2 = tagReg r2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + where + tagReg (FixedReg _) = (ILIT(1) :: FAST_INT) + tagReg (MappedReg _) = ILIT(2) + tagReg (MemoryReg _ _) = ILIT(3) + tagReg (UnmappedReg _ _) = ILIT(4) + +cmp_i :: Int -> Int -> TAG_ +cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_ + +cmp_ihash :: FAST_INT -> FAST_INT -> TAG_ +cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_ + +instance Eq Reg where + a == b = case cmpReg a b of { EQ_ -> True; _ -> False } + a /= b = case cmpReg a b of { EQ_ -> False; _ -> True } + +instance Ord Reg where + a <= b = case cmpReg a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case cmpReg a b of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True } + _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + +instance NamedThing Reg where + -- the *only* method that should be defined is "getItsUnique"! + -- (so we can use UniqFMs/UniqSets on Regs + getItsUnique (UnmappedReg u _) = u + getItsUnique (FixedReg i) = mkPseudoUnique1 IBOX(i) + getItsUnique (MappedReg i) = mkPseudoUnique2 IBOX(i) + getItsUnique (MemoryReg i _) = mkPseudoUnique3 i +\end{code} + +\begin{code} +type RegNo = Int + +realReg :: RegNo -> Reg +realReg n@IBOX(i) + = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i + +extractMappedRegNos :: [Reg] -> [RegNo] + +extractMappedRegNos regs + = foldr ex [] regs + where + ex (MappedReg i) acc = IBOX(i) : acc -- we'll take it + ex _ acc = acc -- leave it out +\end{code} + +** Machine-specific Reg stuff: ** + +The Alpha has 64 registers of interest; 32 integer registers and 32 floating +point registers. The mapping of STG registers to alpha machine registers +is defined in StgRegs.h. We are, of course, prepared for any eventuality. +\begin{code} +#if alpha_TARGET_ARCH +fReg :: Int -> Int +fReg x = (32 + x) + +v0, f0, ra, pv, gp, sp, zero :: Reg +v0 = realReg 0 +f0 = realReg (fReg 0) +ra = FixedReg ILIT(26) +pv = t12 +gp = FixedReg ILIT(29) +sp = FixedReg ILIT(30) +zero = FixedReg ILIT(31) + +t9, t10, t11, t12 :: Reg +t9 = realReg 23 +t10 = realReg 24 +t11 = realReg 25 +t12 = realReg 27 +#endif +\end{code} + +Intel x86 architecture: +- All registers except 7 (esp) are available for use. +- Only ebx, esi, edi and esp are available across a C call (they are callee-saves). +- Registers 0-7 have 16-bit counterparts (ax, bx etc.) +- Registers 0-3 have 8 bit counterparts (ah, bh etc.) +- Registers 8-15 hold extended floating point values. +\begin{code} +#if i386_TARGET_ARCH + +gReg,fReg :: Int -> Int +gReg x = x +fReg x = (8 + x) + +st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg +eax = case (gReg 0) of { IBOX(g0) -> FixedReg g0 } +ebx = case (gReg 1) of { IBOX(g1) -> FixedReg g1 } +ecx = case (gReg 2) of { IBOX(g2) -> FixedReg g2 } +edx = case (gReg 3) of { IBOX(g3) -> FixedReg g3 } +esi = case (gReg 4) of { IBOX(g4) -> FixedReg g4 } +edi = case (gReg 5) of { IBOX(g5) -> FixedReg g5 } +ebp = case (gReg 6) of { IBOX(g6) -> FixedReg g6 } +esp = case (gReg 7) of { IBOX(g7) -> FixedReg g7 } +st0 = realReg (fReg 0) +st1 = realReg (fReg 1) +st2 = realReg (fReg 2) +st3 = realReg (fReg 3) +st4 = realReg (fReg 4) +st5 = realReg (fReg 5) +st6 = realReg (fReg 6) +st7 = realReg (fReg 7) + +#endif +\end{code} + +The SPARC has 64 registers of interest; 32 integer registers and 32 +floating point registers. The mapping of STG registers to SPARC +machine registers is defined in StgRegs.h. We are, of course, +prepared for any eventuality. + +\begin{code} +#if sparc_TARGET_ARCH + +gReg,lReg,iReg,oReg,fReg :: Int -> Int +gReg x = x +oReg x = (8 + x) +lReg x = (16 + x) +iReg x = (24 + x) +fReg x = (32 + x) + +fPair :: Reg -> Reg +fPair (FixedReg i) = FixedReg (i _ADD_ ILIT(1)) +fPair (MappedReg i) = MappedReg (i _ADD_ ILIT(1)) + +g0, fp, sp, o0, f0 :: Reg +g0 = case (gReg 0) of { IBOX(g0) -> FixedReg g0 } +fp = case (iReg 6) of { IBOX(i6) -> FixedReg i6 } +sp = case (oReg 6) of { IBOX(o6) -> FixedReg o6 } +o0 = realReg (oReg 0) +f0 = realReg (fReg 0) + +#endif +\end{code} + +Redefine the literals used for machine-registers with non-numeric +names in the header files. Gag me with a spoon, eh? +\begin{code} +#if alpha_TARGET_ARCH +#define f0 32 +#define f1 33 +#define f2 34 +#define f3 35 +#define f4 36 +#define f5 37 +#define f6 38 +#define f7 39 +#define f8 40 +#define f9 41 +#define f10 42 +#define f11 43 +#define f12 44 +#define f13 45 +#define f14 46 +#define f15 47 +#define f16 48 +#define f17 49 +#define f18 50 +#define f19 51 +#define f20 52 +#define f21 53 +#define f22 54 +#define f23 55 +#define f24 56 +#define f25 57 +#define f26 58 +#define f27 59 +#define f28 60 +#define f29 61 +#define f30 62 +#define f31 63 +#endif +#if i386_TARGET_ARCH +#define eax 0 +#define ebx 1 +#define ecx 2 +#define edx 3 +#define esi 4 +#define edi 5 +#define ebp 6 +#define esp 7 +#define st0 8 +#define st1 9 +#define st2 10 +#define st3 11 +#define st4 12 +#define st5 13 +#define st6 14 +#define st7 15 +#endif +#if sparc_TARGET_ARCH +#define g0 0 +#define g1 1 +#define g2 2 +#define g3 3 +#define g4 4 +#define g5 5 +#define g6 6 +#define g7 7 +#define o0 8 +#define o1 9 +#define o2 10 +#define o3 11 +#define o4 12 +#define o5 13 +#define o6 14 +#define o7 15 +#define l0 16 +#define l1 17 +#define l2 18 +#define l3 19 +#define l4 20 +#define l5 21 +#define l6 22 +#define l7 23 +#define i0 24 +#define i1 25 +#define i2 26 +#define i3 27 +#define i4 28 +#define i5 29 +#define i6 30 +#define i7 31 +#define f0 32 +#define f1 33 +#define f2 34 +#define f3 35 +#define f4 36 +#define f5 37 +#define f6 38 +#define f7 39 +#define f8 40 +#define f9 41 +#define f10 42 +#define f11 43 +#define f12 44 +#define f13 45 +#define f14 46 +#define f15 47 +#define f16 48 +#define f17 49 +#define f18 50 +#define f19 51 +#define f20 52 +#define f21 53 +#define f22 54 +#define f23 55 +#define f24 56 +#define f25 57 +#define f26 58 +#define f27 59 +#define f28 60 +#define f29 61 +#define f30 62 +#define f31 63 +#endif +\end{code} + +\begin{code} +baseRegOffset :: MagicId -> Int + +baseRegOffset StkOReg = OFFSET_StkO +baseRegOffset (VanillaReg _ ILIT(1)) = OFFSET_R1 +baseRegOffset (VanillaReg _ ILIT(2)) = OFFSET_R2 +baseRegOffset (VanillaReg _ ILIT(3)) = OFFSET_R3 +baseRegOffset (VanillaReg _ ILIT(4)) = OFFSET_R4 +baseRegOffset (VanillaReg _ ILIT(5)) = OFFSET_R5 +baseRegOffset (VanillaReg _ ILIT(6)) = OFFSET_R6 +baseRegOffset (VanillaReg _ ILIT(7)) = OFFSET_R7 +baseRegOffset (VanillaReg _ ILIT(8)) = OFFSET_R8 +baseRegOffset (FloatReg ILIT(1)) = OFFSET_Flt1 +baseRegOffset (FloatReg ILIT(2)) = OFFSET_Flt2 +baseRegOffset (FloatReg ILIT(3)) = OFFSET_Flt3 +baseRegOffset (FloatReg ILIT(4)) = OFFSET_Flt4 +baseRegOffset (DoubleReg ILIT(1)) = OFFSET_Dbl1 +baseRegOffset (DoubleReg ILIT(2)) = OFFSET_Dbl2 +baseRegOffset TagReg = OFFSET_Tag +baseRegOffset RetReg = OFFSET_Ret +baseRegOffset SpA = OFFSET_SpA +baseRegOffset SuA = OFFSET_SuA +baseRegOffset SpB = OFFSET_SpB +baseRegOffset SuB = OFFSET_SuB +baseRegOffset Hp = OFFSET_Hp +baseRegOffset HpLim = OFFSET_HpLim +baseRegOffset LivenessReg = OFFSET_Liveness +#ifdef DEBUG +baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" +baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg" +baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg" +baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre" +baseRegOffset VoidReg = panic "baseRegOffset:VoidReg" +#endif +\end{code} + +\begin{code} +callerSaves :: MagicId -> Bool + +#ifdef CALLER_SAVES_Base +callerSaves BaseReg = True +#endif +#ifdef CALLER_SAVES_StkO +callerSaves StkOReg = True +#endif +#ifdef CALLER_SAVES_R1 +callerSaves (VanillaReg _ ILIT(1)) = True +#endif +#ifdef CALLER_SAVES_R2 +callerSaves (VanillaReg _ ILIT(2)) = True +#endif +#ifdef CALLER_SAVES_R3 +callerSaves (VanillaReg _ ILIT(3)) = True +#endif +#ifdef CALLER_SAVES_R4 +callerSaves (VanillaReg _ ILIT(4)) = True +#endif +#ifdef CALLER_SAVES_R5 +callerSaves (VanillaReg _ ILIT(5)) = True +#endif +#ifdef CALLER_SAVES_R6 +callerSaves (VanillaReg _ ILIT(6)) = True +#endif +#ifdef CALLER_SAVES_R7 +callerSaves (VanillaReg _ ILIT(7)) = True +#endif +#ifdef CALLER_SAVES_R8 +callerSaves (VanillaReg _ ILIT(8)) = True +#endif +#ifdef CALLER_SAVES_FltReg1 +callerSaves (FloatReg ILIT(1)) = True +#endif +#ifdef CALLER_SAVES_FltReg2 +callerSaves (FloatReg ILIT(2)) = True +#endif +#ifdef CALLER_SAVES_FltReg3 +callerSaves (FloatReg ILIT(3)) = True +#endif +#ifdef CALLER_SAVES_FltReg4 +callerSaves (FloatReg ILIT(4)) = True +#endif +#ifdef CALLER_SAVES_DblReg1 +callerSaves (DoubleReg ILIT(1)) = True +#endif +#ifdef CALLER_SAVES_DblReg2 +callerSaves (DoubleReg ILIT(2)) = True +#endif +#ifdef CALLER_SAVES_Tag +callerSaves TagReg = True +#endif +#ifdef CALLER_SAVES_Ret +callerSaves RetReg = True +#endif +#ifdef CALLER_SAVES_SpA +callerSaves SpA = True +#endif +#ifdef CALLER_SAVES_SuA +callerSaves SuA = True +#endif +#ifdef CALLER_SAVES_SpB +callerSaves SpB = True +#endif +#ifdef CALLER_SAVES_SuB +callerSaves SuB = True +#endif +#ifdef CALLER_SAVES_Hp +callerSaves Hp = True +#endif +#ifdef CALLER_SAVES_HpLim +callerSaves HpLim = True +#endif +#ifdef CALLER_SAVES_Liveness +callerSaves LivenessReg = True +#endif +#ifdef CALLER_SAVES_StdUpdRetVec +callerSaves StdUpdRetVecReg = True +#endif +#ifdef CALLER_SAVES_StkStub +callerSaves StkStubReg = True +#endif +callerSaves _ = False +\end{code} + +\begin{code} +magicIdRegMaybe :: MagicId -> Maybe Reg + +#ifdef REG_Base +magicIdRegMaybe BaseReg = Just (FixedReg ILIT(REG_Base)) +#endif +#ifdef REG_StkO +magicIdRegMaybe StkOReg = Just (FixedReg ILIT(REG_StkOReg)) +#endif +#ifdef REG_R1 +magicIdRegMaybe (VanillaReg _ ILIT(1)) = Just (FixedReg ILIT(REG_R1)) +#endif +#ifdef REG_R2 +magicIdRegMaybe (VanillaReg _ ILIT(2)) = Just (FixedReg ILIT(REG_R2)) +#endif +#ifdef REG_R3 +magicIdRegMaybe (VanillaReg _ ILIT(3)) = Just (FixedReg ILIT(REG_R3)) +#endif +#ifdef REG_R4 +magicIdRegMaybe (VanillaReg _ ILIT(4)) = Just (FixedReg ILIT(REG_R4)) +#endif +#ifdef REG_R5 +magicIdRegMaybe (VanillaReg _ ILIT(5)) = Just (FixedReg ILIT(REG_R5)) +#endif +#ifdef REG_R6 +magicIdRegMaybe (VanillaReg _ ILIT(6)) = Just (FixedReg ILIT(REG_R6)) +#endif +#ifdef REG_R7 +magicIdRegMaybe (VanillaReg _ ILIT(7)) = Just (FixedReg ILIT(REG_R7)) +#endif +#ifdef REG_R8 +magicIdRegMaybe (VanillaReg _ ILIT(8)) = Just (FixedReg ILIT(REG_R8)) +#endif +#ifdef REG_Flt1 +magicIdRegMaybe (FloatReg ILIT(1)) = Just (FixedReg ILIT(REG_Flt1)) +#endif +#ifdef REG_Flt2 +magicIdRegMaybe (FloatReg ILIT(2)) = Just (FixedReg ILIT(REG_Flt2)) +#endif +#ifdef REG_Flt3 +magicIdRegMaybe (FloatReg ILIT(3)) = Just (FixedReg ILIT(REG_Flt3)) +#endif +#ifdef REG_Flt4 +magicIdRegMaybe (FloatReg ILIT(4)) = Just (FixedReg ILIT(REG_Flt4)) +#endif +#ifdef REG_Dbl1 +magicIdRegMaybe (DoubleReg ILIT(1)) = Just (FixedReg ILIT(REG_Dbl1)) +#endif +#ifdef REG_Dbl2 +magicIdRegMaybe (DoubleReg ILIT(2)) = Just (FixedReg ILIT(REG_Dbl2)) +#endif +#ifdef REG_Tag +magicIdRegMaybe TagReg = Just (FixedReg ILIT(REG_TagReg)) +#endif +#ifdef REG_Ret +magicIdRegMaybe RetReg = Just (FixedReg ILIT(REG_Ret)) +#endif +#ifdef REG_SpA +magicIdRegMaybe SpA = Just (FixedReg ILIT(REG_SpA)) +#endif +#ifdef REG_SuA +magicIdRegMaybe SuA = Just (FixedReg ILIT(REG_SuA)) +#endif +#ifdef REG_SpB +magicIdRegMaybe SpB = Just (FixedReg ILIT(REG_SpB)) +#endif +#ifdef REG_SuB +magicIdRegMaybe SuB = Just (FixedReg ILIT(REG_SuB)) +#endif +#ifdef REG_Hp +magicIdRegMaybe Hp = Just (FixedReg ILIT(REG_Hp)) +#endif +#ifdef REG_HpLim +magicIdRegMaybe HpLim = Just (FixedReg ILIT(REG_HpLim)) +#endif +#ifdef REG_Liveness +magicIdRegMaybe LivenessReg = Just (FixedReg ILIT(REG_Liveness)) +#endif +#ifdef REG_StdUpdRetVec +magicIdRegMaybe StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec)) +#endif +#ifdef REG_StkStub +magicIdRegMaybe StkStubReg = Just (FixedReg ILIT(REG_StkStub)) +#endif +magicIdRegMaybe _ = Nothing +\end{code} + +%************************************************************************ +%* * +\subsection{Free, reserved, call-clobbered, and argument registers} +%* * +%************************************************************************ + +@freeRegs@ is the list of registers we can use in register allocation. +@freeReg@ (below) says if a particular register is free. + +With a per-instruction clobber list, we might be able to get some of +these back, but it's probably not worth the hassle. + +@callClobberedRegs@ ... the obvious. + +@argRegs@: assuming a call with N arguments, what registers will be +used to hold arguments? (NB: it doesn't know whether the arguments +are integer or floating-point...) + +\begin{code} +reservedRegs :: [RegNo] +reservedRegs +#if alpha_TARGET_ARCH + = [NCG_Reserved_I1, NCG_Reserved_I2, + NCG_Reserved_F1, NCG_Reserved_F2] +#endif +#if i386_TARGET_ARCH + = [{-certainly cannot afford any!-}] +#endif +#if sparc_TARGET_ARCH + = [NCG_Reserved_I1, NCG_Reserved_I2, + NCG_Reserved_F1, NCG_Reserved_F2, + NCG_Reserved_D1, NCG_Reserved_D2] +#endif + +------------------------------- +freeRegs :: [Reg] +freeRegs + = freeMappedRegs IF_ARCH_alpha( [0..63], + IF_ARCH_i386( [0..15], + IF_ARCH_sparc( [0..63],))) + +------------------------------- +callClobberedRegs :: [Reg] +callClobberedRegs + = freeMappedRegs +#if alpha_TARGET_ARCH + [0, 1, 2, 3, 4, 5, 6, 7, 8, + 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, + fReg 0, fReg 1, fReg 10, fReg 11, fReg 12, fReg 13, fReg 14, fReg 15, + fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21, fReg 22, fReg 23, + fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30] +#endif {- alpha_TARGET_ARCH -} +#if i386_TARGET_ARCH + [{-none-}] +#endif {- i386_TARGET_ARCH -} +#if sparc_TARGET_ARCH + ( oReg 7 : + [oReg i | i <- [0..5]] ++ + [gReg i | i <- [1..7]] ++ + [fReg i | i <- [0..31]] ) +#endif {- sparc_TARGET_ARCH -} + +------------------------------- +argRegs :: Int -> [Reg] + +argRegs 0 = [] +#if alpha_TARGET_ARCH +argRegs 1 = freeMappedRegs [16, fReg 16] +argRegs 2 = freeMappedRegs [16, 17, fReg 16, fReg 17] +argRegs 3 = freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18] +argRegs 4 = freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19] +argRegs 5 = freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20] +argRegs 6 = freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21] +#endif {- alpha_TARGET_ARCH -} +#if i386_TARGET_ARCH +argRegs _ = panic "MachRegs.argRegs: doesn't work on I386" +#endif {- i386_TARGET_ARCH -} +#if sparc_TARGET_ARCH +argRegs 1 = freeMappedRegs (map oReg [0]) +argRegs 2 = freeMappedRegs (map oReg [0,1]) +argRegs 3 = freeMappedRegs (map oReg [0,1,2]) +argRegs 4 = freeMappedRegs (map oReg [0,1,2,3]) +argRegs 5 = freeMappedRegs (map oReg [0,1,2,3,4]) +argRegs 6 = freeMappedRegs (map oReg [0,1,2,3,4,5]) +#endif {- sparc_TARGET_ARCH -} +argRegs _ = panic "MachRegs.argRegs: don't know about >6 arguments!" + +------------------------------- + +#if alpha_TARGET_ARCH +allArgRegs :: [(Reg, Reg)] + +allArgRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]] +#endif {- alpha_TARGET_ARCH -} + +#if sparc_TARGET_ARCH +allArgRegs :: [Reg] + +allArgRegs = map realReg [oReg i | i <- [0..5]] +#endif {- sparc_TARGET_ARCH -} + +------------------------------- +freeMappedRegs :: [Int] -> [Reg] + +freeMappedRegs nums + = foldr free [] nums + where + free IBOX(i) acc + = if _IS_TRUE_(freeReg i) then (MappedReg i) : acc else acc +\end{code} + +\begin{code} +freeReg :: FAST_INT -> FAST_BOOL + +#if alpha_TARGET_ARCH +freeReg ILIT(26) = _FALSE_ -- return address (ra) +freeReg ILIT(28) = _FALSE_ -- reserved for the assembler (at) +freeReg ILIT(29) = _FALSE_ -- global pointer (gp) +freeReg ILIT(30) = _FALSE_ -- stack pointer (sp) +freeReg ILIT(31) = _FALSE_ -- always zero (zero) +freeReg ILIT(63) = _FALSE_ -- always zero (f31) +#endif + +#if i386_TARGET_ARCH +freeReg ILIT(esp) = _FALSE_ -- %esp is the C stack pointer +#endif + +#if sparc_TARGET_ARCH +freeReg ILIT(g0) = _FALSE_ -- %g0 is always 0. +freeReg ILIT(g5) = _FALSE_ -- %g5 is reserved (ABI). +freeReg ILIT(g6) = _FALSE_ -- %g6 is reserved (ABI). +freeReg ILIT(g7) = _FALSE_ -- %g7 is reserved (ABI). +freeReg ILIT(i6) = _FALSE_ -- %i6 is our frame pointer. +freeReg ILIT(o6) = _FALSE_ -- %o6 is our stack pointer. +#endif + +#ifdef REG_Base +freeReg ILIT(REG_Base) = _FALSE_ +#endif +#ifdef REG_StkO +freeReg ILIT(REG_StkO) = _FALSE_ +#endif +#ifdef REG_R1 +freeReg ILIT(REG_R1) = _FALSE_ +#endif +#ifdef REG_R2 +freeReg ILIT(REG_R2) = _FALSE_ +#endif +#ifdef REG_R3 +freeReg ILIT(REG_R3) = _FALSE_ +#endif +#ifdef REG_R4 +freeReg ILIT(REG_R4) = _FALSE_ +#endif +#ifdef REG_R5 +freeReg ILIT(REG_R5) = _FALSE_ +#endif +#ifdef REG_R6 +freeReg ILIT(REG_R6) = _FALSE_ +#endif +#ifdef REG_R7 +freeReg ILIT(REG_R7) = _FALSE_ +#endif +#ifdef REG_R8 +freeReg ILIT(REG_R8) = _FALSE_ +#endif +#ifdef REG_Flt1 +freeReg ILIT(REG_Flt1) = _FALSE_ +#endif +#ifdef REG_Flt2 +freeReg ILIT(REG_Flt2) = _FALSE_ +#endif +#ifdef REG_Flt3 +freeReg ILIT(REG_Flt3) = _FALSE_ +#endif +#ifdef REG_Flt4 +freeReg ILIT(REG_Flt4) = _FALSE_ +#endif +#ifdef REG_Dbl1 +freeReg ILIT(REG_Dbl1) = _FALSE_ +#endif +#ifdef REG_Dbl2 +freeReg ILIT(REG_Dbl2) = _FALSE_ +#endif +#ifdef REG_Tag +freeReg ILIT(REG_Tag) = _FALSE_ +#endif +#ifdef REG_Ret +freeReg ILIT(REG_Ret) = _FALSE_ +#endif +#ifdef REG_SpA +freeReg ILIT(REG_SpA) = _FALSE_ +#endif +#ifdef REG_SuA +freeReg ILIT(REG_SuA) = _FALSE_ +#endif +#ifdef REG_SpB +freeReg ILIT(REG_SpB) = _FALSE_ +#endif +#ifdef REG_SuB +freeReg ILIT(REG_SuB) = _FALSE_ +#endif +#ifdef REG_Hp +freeReg ILIT(REG_Hp) = _FALSE_ +#endif +#ifdef REG_HpLim +freeReg ILIT(REG_HpLim) = _FALSE_ +#endif +#ifdef REG_Liveness +freeReg ILIT(REG_Liveness) = _FALSE_ +#endif +#ifdef REG_StdUpdRetVec +freeReg ILIT(REG_StdUpdRetVec) = _FALSE_ +#endif +#ifdef REG_StkStub +freeReg ILIT(REG_StkStub) = _FALSE_ +#endif +freeReg _ = _TRUE_ +freeReg n + -- we hang onto two double regs for dedicated + -- use; this is not necessary on Alphas and + -- may not be on other non-SPARCs. +#ifdef REG_Dbl1 + | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_ +#endif +#ifdef REG_Dbl2 + | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_ +#endif + | otherwise = _TRUE_ +\end{code} diff --git a/ghc/compiler/nativeGen/NCG.h b/ghc/compiler/nativeGen/NCG.h new file mode 100644 index 0000000..4b3049b --- /dev/null +++ b/ghc/compiler/nativeGen/NCG.h @@ -0,0 +1,150 @@ +#ifndef NCG_H +#define NCG_H + +#if 0 + +IMPORTANT! If you put extra tabs/spaces in these macro definitions, +you will screw up the layout where they are used in case expressions! + +(This is cpp-dependent, of course) + +** Convenience macros for writing the native-code generator ** + +#endif + +#define FAST_REG_NO FAST_INT + +#include "../../includes/platform.h" + +#if 0 +{-testing only-} +#undef sparc_TARGET_ARCH +#undef sunos4_TARGET_OS +#undef i386_TARGET_ARCH +#define i386_TARGET_ARCH 1 +#undef linuxaout_TARGET_OS +#define linuxaout_TARGET_OS 1 +#endif +#if 0 +{-testing only-} +#undef sparc_TARGET_ARCH +#undef sunos4_TARGET_OS +#undef alpha_TARGET_ARCH +#define alpha_TARGET_ARCH 1 +#endif + +#if i386_TARGET_ARCH +# define STOLEN_X86_REGS 4 +-- HACK: go for the max +#endif +#include "../../includes/MachRegs.h" + +#if alpha_TARGET_ARCH +# define BYTES_PER_WORD 8 +# define BYTES_PER_WORD_STR "8" + +# include "../../includes/alpha-dec-osf1.h" +#endif + +#if i386_TARGET_ARCH +# define BYTES_PER_WORD 4 +# define BYTES_PER_WORD_STR "4" + +# if linuxaout_TARGET_OS +# include "../../includes/i386-unknown-linuxaout.h" +# endif +# if linux_TARGET_OS +# include "../../includes/i386-unknown-linux.h" +# endif +# if freebsd_TARGET_OS +# include "../../includes/i386-unknown-freebsd.h" +# endif +# if netbsd_TARGET_OS +# include "../../includes/i386-unknown-netbsd.h" +# endif +# if bsdi_TARGET_OS +# include "../../includes/i386-unknown-bsdi.h" +# endif +# if solaris2_TARGET_OS +# include "../../includes/i386-unknown-solaris2.h" +# endif +#endif + +#if sparc_TARGET_ARCH +# define BYTES_PER_WORD 4 +# define BYTES_PER_WORD_STR "4" + +# if sunos4_TARGET_OS +# include "../../includes/sparc-sun-sunos4.h" +# endif +# if solaris2_TARGET_OS +# include "../../includes/sparc-sun-solaris2.h" +# endif +#endif + +--------------------------------------------- + +#if alpha_TARGET_ARCH +# define IF_ARCH_alpha(x,y) x +#else +# define IF_ARCH_alpha(x,y) y +#endif + +--------------------------------------------- + +#if i386_TARGET_ARCH +# define IF_ARCH_i386(x,y) x +#else +# define IF_ARCH_i386(x,y) y +#endif +-- - - - - - - - - - - - - - - - - - - - - - +#if freebsd_TARGET_OS +# define IF_OS_freebsd(x,y) x +#else +# define IF_OS_freebsd(x,y) y +#endif +-- - - - - - - - - - - - - - - - - - - - - - +#if netbsd_TARGET_OS +# define IF_OS_netbsd(x,y) x +#else +# define IF_OS_netbsd(x,y) y +#endif +-- - - - - - - - - - - - - - - - - - - - - - +#if linux_TARGET_OS +# define IF_OS_linux(x,y) x +#else +# define IF_OS_linux(x,y) y +#endif +-- - - - - - - - - - - - - - - - - - - - - - +#if linuxaout_TARGET_OS +# define IF_OS_linuxaout(x,y) x +#else +# define IF_OS_linuxaout(x,y) y +#endif +-- - - - - - - - - - - - - - - - - - - - - - +#if bsdi_TARGET_OS +# define IF_OS_bsdi(x,y) x +#else +# define IF_OS_bsdi(x,y) y +#endif +--------------------------------------------- +#if sparc_TARGET_ARCH +# define IF_ARCH_sparc(x,y) x +#else +# define IF_ARCH_sparc(x,y) y +#endif +-- - - - - - - - - - - - - - - - - - - - - - +#if sunos4_TARGET_OS +# define IF_OS_sunos4(x,y) x +#else +# define IF_OS_sunos4(x,y) y +#endif +-- - - - - - - - - - - - - - - - - - - - - - +-- NB: this will catch i386-*-solaris2, too +#if solaris2_TARGET_OS +# define IF_OS_solaris2(x,y) x +#else +# define IF_OS_solaris2(x,y) y +#endif +--------------------------------------------- +#endif diff --git a/ghc/compiler/nativeGen/NcgLoop.lhi b/ghc/compiler/nativeGen/NcgLoop.lhi new file mode 100644 index 0000000..9086b31 --- /dev/null +++ b/ghc/compiler/nativeGen/NcgLoop.lhi @@ -0,0 +1,16 @@ +Breaks loops between Stix{Macro,Prim,Integer}.lhs. + +Also some CLabel dependencies on MachMisc. + +\begin{code} +interface NcgLoop where + +import AbsCSyn ( CAddrMode ) +import Stix ( StixTree ) +import MachMisc ( underscorePrefix, fmtAsmLbl ) +import StixPrim ( amodeToStix ) + +amodeToStix :: CAddrMode -> StixTree +underscorePrefix :: Bool +fmtAsmLbl :: [Char] -> [Char] +\end{code} diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs new file mode 100644 index 0000000..f1835a3 --- /dev/null +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -0,0 +1,1323 @@ +% +% (c) The AQUA Project, Glasgow University, 1996 +% +\section[PprMach]{Pretty-printing assembly language} + +We start with the @pprXXX@s with some cross-platform commonality +(e.g., @pprReg@); we conclude with the no-commonality monster, +@pprInstr@. + +\begin{code} +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +module PprMach ( pprInstr ) where + +import Ubiq{-uitious-} + +import MachRegs -- may differ per-platform +import MachMisc + +import CLabel ( pprCLabel_asm, externallyVisibleCLabel ) +import CStrings ( charToC ) +import Maybes ( maybeToBool ) +import OrdList ( OrdList ) +import Stix ( CodeSegment(..), StixTree ) +import Unpretty -- all of it +\end{code} + +%************************************************************************ +%* * +\subsection{@pprReg@: print a @Reg@} +%* * +%************************************************************************ + +For x86, the way we print a register name depends +on which bit of it we care about. Yurgh. +\begin{code} +pprReg :: IF_ARCH_i386(Size ->,) Reg -> Unpretty + +pprReg IF_ARCH_i386(s,) r + = case r of + FixedReg i -> ppr_reg_no IF_ARCH_i386(s,) i + MappedReg i -> ppr_reg_no IF_ARCH_i386(s,) i + other -> uppStr (show other) -- should only happen when debugging + where +#if alpha_TARGET_ARCH + ppr_reg_no :: FAST_REG_NO -> Unpretty + ppr_reg_no i = uppPStr + (case i of { + ILIT( 0) -> SLIT("$0"); ILIT( 1) -> SLIT("$1"); + ILIT( 2) -> SLIT("$2"); ILIT( 3) -> SLIT("$3"); + ILIT( 4) -> SLIT("$4"); ILIT( 5) -> SLIT("$5"); + ILIT( 6) -> SLIT("$6"); ILIT( 7) -> SLIT("$7"); + ILIT( 8) -> SLIT("$8"); ILIT( 9) -> SLIT("$9"); + ILIT(10) -> SLIT("$10"); ILIT(11) -> SLIT("$11"); + ILIT(12) -> SLIT("$12"); ILIT(13) -> SLIT("$13"); + ILIT(14) -> SLIT("$14"); ILIT(15) -> SLIT("$15"); + ILIT(16) -> SLIT("$16"); ILIT(17) -> SLIT("$17"); + ILIT(18) -> SLIT("$18"); ILIT(19) -> SLIT("$19"); + ILIT(20) -> SLIT("$20"); ILIT(21) -> SLIT("$21"); + ILIT(22) -> SLIT("$22"); ILIT(23) -> SLIT("$23"); + ILIT(24) -> SLIT("$24"); ILIT(25) -> SLIT("$25"); + ILIT(26) -> SLIT("$26"); ILIT(27) -> SLIT("$27"); + ILIT(28) -> SLIT("$28"); ILIT(29) -> SLIT("$29"); + ILIT(30) -> SLIT("$30"); ILIT(31) -> SLIT("$31"); + 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(38) -> SLIT("$f6"); ILIT(39) -> SLIT("$f7"); + 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(46) -> SLIT("$f14"); ILIT(47) -> SLIT("$f15"); + 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(54) -> SLIT("$f22"); ILIT(55) -> SLIT("$f23"); + 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(62) -> SLIT("$f30"); ILIT(63) -> SLIT("$f31"); + _ -> SLIT("very naughty alpha register") + }) +#endif +#if i386_TARGET_ARCH + ppr_reg_no :: Size -> FAST_REG_NO -> Unpretty + ppr_reg_no B i = uppPStr + (case i of { + ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl"); + ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl"); + _ -> SLIT("very naughty I386 byte register") + }) + + {- UNUSED: + ppr_reg_no HB i = uppPStr + (case i of { + ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh"); + ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh"); + _ -> SLIT("very naughty I386 high byte register") + }) + -} + +{- UNUSED: + ppr_reg_no S i = uppPStr + (case i of { + 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( 6) -> SLIT("%bp"); ILIT( 7) -> SLIT("%sp"); + _ -> SLIT("very naughty I386 word register") + }) +-} + + ppr_reg_no L i = uppPStr + (case i of { + 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( 6) -> SLIT("%ebp"); ILIT( 7) -> SLIT("%esp"); + _ -> SLIT("very naughty I386 double word register") + }) + + ppr_reg_no F i = uppPStr + (case i of { + --ToDo: rm these (???) + 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(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)"); + _ -> SLIT("very naughty I386 float register") + }) + + ppr_reg_no DF i = uppPStr + (case i of { + --ToDo: rm these (???) + 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(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)"); + _ -> SLIT("very naughty I386 float register") + }) +#endif +#if sparc_TARGET_ARCH + ppr_reg_no :: FAST_REG_NO -> Unpretty + ppr_reg_no i = uppPStr + (case i of { + 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( 6) -> SLIT("%g6"); ILIT( 7) -> SLIT("%g7"); + 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(14) -> SLIT("%o6"); ILIT(15) -> SLIT("%o7"); + 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(22) -> SLIT("%l6"); ILIT(23) -> SLIT("%l7"); + 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(30) -> SLIT("%i6"); ILIT(31) -> SLIT("%i7"); + 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(38) -> SLIT("%f6"); ILIT(39) -> SLIT("%f7"); + 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(46) -> SLIT("%f14"); ILIT(47) -> SLIT("%f15"); + 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(54) -> SLIT("%f22"); ILIT(55) -> SLIT("%f23"); + 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(62) -> SLIT("%f30"); ILIT(63) -> SLIT("%f31"); + _ -> SLIT("very naughty sparc register") + }) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{@pprSize@: print a @Size@} +%* * +%************************************************************************ + +\begin{code} +pprSize :: Size -> Unpretty + +pprSize x = uppPStr (case x of +#if alpha_TARGET_ARCH + B -> SLIT("b") + BU -> SLIT("bu") +-- W -> SLIT("w") UNUSED +-- WU -> SLIT("wu") UNUSED +-- L -> SLIT("l") UNUSED + Q -> SLIT("q") +-- FF -> SLIT("f") UNUSED +-- DF -> SLIT("d") UNUSED +-- GF -> SLIT("g") UNUSED +-- SF -> SLIT("s") UNUSED + TF -> SLIT("t") +#endif +#if i386_TARGET_ARCH + B -> SLIT("b") +-- HB -> SLIT("b") UNUSED +-- S -> SLIT("w") UNUSED + L -> SLIT("l") + F -> SLIT("s") + DF -> SLIT("l") +#endif +#if sparc_TARGET_ARCH + B -> SLIT("sb") +-- HW -> SLIT("hw") UNUSED +-- BU -> SLIT("ub") UNUSED +-- HWU -> SLIT("uhw") UNUSED + W -> SLIT("") + F -> SLIT("") +-- D -> SLIT("d") UNUSED + DF -> SLIT("d") +#endif + ) +\end{code} + +%************************************************************************ +%* * +\subsection{@pprCond@: print a @Cond@} +%* * +%************************************************************************ + +\begin{code} +pprCond :: Cond -> Unpretty + +pprCond c = uppPStr (case c of { +#if alpha_TARGET_ARCH + EQ -> SLIT("eq"); + LT -> SLIT("lt"); + LE -> SLIT("le"); + ULT -> SLIT("ult"); + ULE -> SLIT("ule"); + NE -> SLIT("ne"); + GT -> SLIT("gt"); + GE -> SLIT("ge") +#endif +#if i386_TARGET_ARCH + GEU -> SLIT("ae"); LU -> SLIT("b"); + EQ -> SLIT("e"); GT -> SLIT("g"); + GE -> SLIT("ge"); GU -> SLIT("a"); + LT -> SLIT("l"); LE -> SLIT("le"); + LEU -> SLIT("be"); NE -> SLIT("ne"); + NEG -> SLIT("s"); POS -> SLIT("ns"); + ALWAYS -> SLIT("mp") -- hack +#endif +#if sparc_TARGET_ARCH + ALWAYS -> SLIT(""); NEVER -> SLIT("n"); + GEU -> SLIT("geu"); LU -> SLIT("lu"); + EQ -> SLIT("e"); GT -> SLIT("g"); + GE -> SLIT("ge"); GU -> SLIT("gu"); + LT -> SLIT("l"); LE -> SLIT("le"); + LEU -> SLIT("leu"); NE -> SLIT("ne"); + NEG -> SLIT("neg"); POS -> SLIT("pos"); + VC -> SLIT("vc"); VS -> SLIT("vs") +#endif + }) +\end{code} + +%************************************************************************ +%* * +\subsection{@pprImm@: print an @Imm@} +%* * +%************************************************************************ + +\begin{code} +pprImm :: Imm -> Unpretty + +pprImm (ImmInt i) = uppInt i +pprImm (ImmInteger i) = uppInteger i +pprImm (ImmCLbl l) = pprCLabel_asm l +pprImm (ImmLit s) = s + +pprImm (ImmLab s) | underscorePrefix = uppBeside (uppChar '_') s + | otherwise = s + +#if sparc_TARGET_ARCH +pprImm (LO i) + = uppBesides [ pp_lo, pprImm i, uppRparen ] + where + pp_lo = uppPStr (_packCString (A# "%lo("#)) + +pprImm (HI i) + = uppBesides [ pp_hi, pprImm i, uppRparen ] + where + pp_hi = uppPStr (_packCString (A# "%hi("#)) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{@pprAddr@: print an @Addr@} +%* * +%************************************************************************ + +\begin{code} +pprAddr :: Addr -> Unpretty + +#if alpha_TARGET_ARCH +pprAddr (AddrReg r) = uppParens (pprReg r) +pprAddr (AddrImm i) = pprImm i +pprAddr (AddrRegImm r1 i) + = uppBeside (pprImm i) (uppParens (pprReg r1)) +#endif + +------------------- + +#if i386_TARGET_ARCH +pprAddr (ImmAddr imm off) + = let + pp_imm = pprImm imm + in + if (off == 0) then + pp_imm + else if (off < 0) then + uppBeside pp_imm (uppInt off) + else + uppBesides [pp_imm, uppChar '+', uppInt off] + +pprAddr (Addr base index displacement) + = let + pp_disp = ppr_disp displacement + pp_off p = uppBeside pp_disp (uppParens p) + pp_reg r = pprReg L r + in + case (base,index) of + (Nothing, Nothing) -> pp_disp + (Just b, Nothing) -> pp_off (pp_reg b) + (Nothing, Just (r,i)) -> pp_off (uppBesides [pp_reg r, uppComma, uppInt i]) + (Just b, Just (r,i)) -> pp_off (uppBesides [pp_reg b, uppComma, pp_reg r, uppComma, uppInt i]) + where + ppr_disp (ImmInt 0) = uppNil + ppr_disp imm = pprImm imm +#endif + +------------------- + +#if sparc_TARGET_ARCH +pprAddr (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1 + +pprAddr (AddrRegReg r1 r2) + = uppBesides [ pprReg r1, uppChar '+', pprReg r2 ] + +pprAddr (AddrRegImm r1 (ImmInt i)) + | i == 0 = pprReg r1 + | not (fits13Bits i) = largeOffsetError i + | otherwise = uppBesides [ pprReg r1, pp_sign, uppInt i ] + where + pp_sign = if i > 0 then uppChar '+' else uppNil + +pprAddr (AddrRegImm r1 (ImmInteger i)) + | i == 0 = pprReg r1 + | not (fits13Bits i) = largeOffsetError i + | otherwise = uppBesides [ pprReg r1, pp_sign, uppInteger i ] + where + pp_sign = if i > 0 then uppChar '+' else uppNil + +pprAddr (AddrRegImm r1 imm) + = uppBesides [ pprReg r1, uppChar '+', pprImm imm ] +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{@pprInstr@: print an @Instr@} +%* * +%************************************************************************ + +\begin{code} +pprInstr :: Instr -> Unpretty + +pprInstr (COMMENT s) = uppBeside (uppPStr SLIT("\t# ")) (uppPStr s) + +pprInstr (SEGMENT TextSegment) + = uppPStr + IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-} + ,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-} + ,IF_ARCH_i386(SLIT(".text\n\t.align 2,0x90") {-needs per-OS variation!-} + ,))) + +pprInstr (SEGMENT DataSegment) + = uppPStr + IF_ARCH_alpha(SLIT("\t.data\n\t.align 3") + ,IF_ARCH_sparc(SLIT("\t.data\n\t.align 8") {-<8 will break double constants -} + ,IF_ARCH_i386(SLIT(".data\n\t.align 2") + ,))) + +pprInstr (LABEL clab) + = let + pp_lab = pprCLabel_asm clab + in + uppBesides [ + if not (externallyVisibleCLabel clab) then + uppNil + else + uppBesides [uppPStr + IF_ARCH_alpha(SLIT("\t.globl\t") + ,IF_ARCH_i386(SLIT(".globl ") + ,IF_ARCH_sparc(SLIT("\t.global\t") + ,))) + , pp_lab, uppChar '\n'], + pp_lab, + uppChar ':' + ] + +pprInstr (ASCII False{-no backslash conversion-} str) + = uppBesides [ uppStr "\t.asciz \"", uppStr str, uppChar '"' ] + +pprInstr (ASCII True str) + = uppBeside (uppStr "\t.ascii \"") (asciify str 60) + where + 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 [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\"")) + asciify (c:(cs@(d:_))) n + | isDigit d = uppBeside (uppStr (charToC c)) (asciify cs 0) + | otherwise = uppBeside (uppStr (charToC c)) (asciify cs (n-1)) + +pprInstr (DATA s xs) + = uppInterleave (uppChar '\n') + [uppBeside (uppPStr pp_size) (pprImm x) | x <- xs] + where + pp_size = case s of +#if alpha_TARGET_ARCH + B -> SLIT("\t.byte\t") + BU -> SLIT("\t.byte\t") +--UNUSED: W -> SLIT("\t.word\t") +--UNUSED: WU -> SLIT("\t.word\t") +--UNUSED: L -> SLIT("\t.long\t") + Q -> SLIT("\t.quad\t") +--UNUSED: FF -> SLIT("\t.f_floating\t") +--UNUSED: DF -> SLIT("\t.d_floating\t") +--UNUSED: GF -> SLIT("\t.g_floating\t") +--UNUSED: SF -> SLIT("\t.s_floating\t") + TF -> SLIT("\t.t_floating\t") +#endif +#if i386_TARGET_ARCH + B -> SLIT("\t.byte\t") +--UNUSED: HB -> SLIT("\t.byte\t") +--UNUSED: S -> SLIT("\t.word\t") + L -> SLIT("\t.long\t") + F -> SLIT("\t.long\t") + DF -> SLIT("\t.double\t") +#endif +#if sparc_TARGET_ARCH + B -> SLIT("\t.byte\t") + BU -> SLIT("\t.byte\t") + W -> SLIT("\t.word\t") + DF -> SLIT("\t.double\t") +#endif + +-- fall through to rest of (machine-specific) pprInstr... +\end{code} + +%************************************************************************ +%* * +\subsubsection{@pprInstr@ for an Alpha} +%* * +%************************************************************************ + +\begin{code} +#if alpha_TARGET_ARCH + +pprInstr (LD size reg addr) + = uppBesides [ + uppPStr SLIT("\tld"), + pprSize size, + uppChar '\t', + pprReg reg, + uppComma, + pprAddr addr + ] + +pprInstr (LDA reg addr) + = uppBesides [ + uppPStr SLIT("\tlda\t"), + pprReg reg, + uppComma, + pprAddr addr + ] + +pprInstr (LDAH reg addr) + = uppBesides [ + uppPStr SLIT("\tldah\t"), + pprReg reg, + uppComma, + pprAddr addr + ] + +pprInstr (LDGP reg addr) + = uppBesides [ + uppPStr SLIT("\tldgp\t"), + pprReg reg, + uppComma, + pprAddr addr + ] + +pprInstr (LDI size reg imm) + = uppBesides [ + uppPStr SLIT("\tldi"), + pprSize size, + uppChar '\t', + pprReg reg, + uppComma, + pprImm imm + ] + +pprInstr (ST size reg addr) + = uppBesides [ + uppPStr SLIT("\tst"), + pprSize size, + uppChar '\t', + pprReg reg, + uppComma, + pprAddr addr + ] + +pprInstr (CLR reg) + = uppBesides [ + uppPStr SLIT("\tclr\t"), + pprReg reg + ] + +pprInstr (ABS size ri reg) + = uppBesides [ + uppPStr SLIT("\tabs"), + pprSize size, + uppChar '\t', + pprRI ri, + uppComma, + pprReg reg + ] + +pprInstr (NEG size ov ri reg) + = uppBesides [ + uppPStr SLIT("\tneg"), + pprSize size, + if ov then uppPStr SLIT("v\t") else uppChar '\t', + pprRI ri, + uppComma, + pprReg reg + ] + +pprInstr (ADD size ov reg1 ri reg2) + = uppBesides [ + uppPStr SLIT("\tadd"), + pprSize size, + if ov then uppPStr SLIT("v\t") else uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprInstr (SADD size scale reg1 ri reg2) + = uppBesides [ + uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}), + uppPStr SLIT("add"), + pprSize size, + uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprInstr (SUB size ov reg1 ri reg2) + = uppBesides [ + uppPStr SLIT("\tsub"), + pprSize size, + if ov then uppPStr SLIT("v\t") else uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprInstr (SSUB size scale reg1 ri reg2) + = uppBesides [ + uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}), + uppPStr SLIT("sub"), + pprSize size, + uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprInstr (MUL size ov reg1 ri reg2) + = uppBesides [ + uppPStr SLIT("\tmul"), + pprSize size, + if ov then uppPStr SLIT("v\t") else uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprInstr (DIV size uns reg1 ri reg2) + = uppBesides [ + uppPStr SLIT("\tdiv"), + pprSize size, + if uns then uppPStr SLIT("u\t") else uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprInstr (REM size uns reg1 ri reg2) + = uppBesides [ + uppPStr SLIT("\trem"), + pprSize size, + if uns then uppPStr SLIT("u\t") else uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprInstr (NOT ri reg) + = uppBesides [ + uppPStr SLIT("\tnot"), + uppChar '\t', + pprRI ri, + uppComma, + pprReg reg + ] + +pprInstr (AND reg1 ri reg2) = pprRegRIReg SLIT("and") reg1 ri reg2 +pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg SLIT("andnot") reg1 ri reg2 +pprInstr (OR reg1 ri reg2) = pprRegRIReg SLIT("or") reg1 ri reg2 +pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg SLIT("ornot") reg1 ri reg2 +pprInstr (XOR reg1 ri reg2) = pprRegRIReg SLIT("xor") reg1 ri reg2 +pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg SLIT("xornot") reg1 ri reg2 + +pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") reg1 ri reg2 +pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") reg1 ri reg2 +pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2 + +pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2 +pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2 + +pprInstr (NOP) = uppPStr SLIT("\tnop") + +pprInstr (CMP cond reg1 ri reg2) + = uppBesides [ + uppPStr SLIT("\tcmp"), + pprCond cond, + uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprInstr (FCLR reg) + = uppBesides [ + uppPStr SLIT("\tfclr\t"), + pprReg reg + ] + +pprInstr (FABS reg1 reg2) + = uppBesides [ + uppPStr SLIT("\tfabs\t"), + pprReg reg1, + uppComma, + pprReg reg2 + ] + +pprInstr (FNEG size reg1 reg2) + = uppBesides [ + uppPStr SLIT("\tneg"), + pprSize size, + uppChar '\t', + pprReg reg1, + uppComma, + pprReg reg2 + ] + +pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("add") size reg1 reg2 reg3 +pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("div") size reg1 reg2 reg3 +pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg2 reg3 +pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3 + +pprInstr (CVTxy size1 size2 reg1 reg2) + = uppBesides [ + uppPStr SLIT("\tcvt"), + pprSize size1, + case size2 of {Q -> uppPStr SLIT("qc"); _ -> pprSize size2}, + uppChar '\t', + pprReg reg1, + uppComma, + pprReg reg2 + ] + +pprInstr (FCMP size cond reg1 reg2 reg3) + = uppBesides [ + uppPStr SLIT("\tcmp"), + pprSize size, + pprCond cond, + uppChar '\t', + pprReg reg1, + uppComma, + pprReg reg2, + uppComma, + pprReg reg3 + ] + +pprInstr (FMOV reg1 reg2) + = uppBesides [ + uppPStr SLIT("\tfmov\t"), + pprReg reg1, + uppComma, + pprReg reg2 + ] + +pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab) + +pprInstr (BI NEVER reg lab) = uppNil + +pprInstr (BI cond reg lab) + = uppBesides [ + uppPStr SLIT("\tb"), + pprCond cond, + uppChar '\t', + pprReg reg, + uppComma, + pprImm lab + ] + +pprInstr (BF cond reg lab) + = uppBesides [ + uppPStr SLIT("\tfb"), + pprCond cond, + uppChar '\t', + pprReg reg, + uppComma, + pprImm lab + ] + +pprInstr (BR lab) + = uppBeside (uppPStr SLIT("\tbr\t")) (pprImm lab) + +pprInstr (JMP reg addr hint) + = uppBesides [ + uppPStr SLIT("\tjmp\t"), + pprReg reg, + uppComma, + pprAddr addr, + uppComma, + uppInt hint + ] + +pprInstr (BSR imm n) + = uppBeside (uppPStr SLIT("\tbsr\t")) (pprImm imm) + +pprInstr (JSR reg addr n) + = uppBesides [ + uppPStr SLIT("\tjsr\t"), + pprReg reg, + uppComma, + pprAddr addr + ] + +pprInstr (FUNBEGIN clab) + = uppBesides [ + if (externallyVisibleCLabel clab) then + uppBesides [uppPStr SLIT("\t.globl\t"), pp_lab, uppChar '\n'] + else + uppNil, + uppPStr SLIT("\t.ent "), + pp_lab, + uppChar '\n', + pp_lab, + pp_ldgp, + pp_lab, + pp_frame + ] + where + pp_lab = pprCLabel_asm clab + pp_ldgp = uppPStr (_packCString (A# ":\n\tldgp $29,0($27)\n"#)) + pp_frame = uppPStr (_packCString (A# "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#)) + +pprInstr (FUNEND clab) + = uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab) +\end{code} + +Continue with Alpha-only printing bits and bobs: +\begin{code} +pprRI :: RI -> Unpretty + +pprRI (RIReg r) = pprReg r +pprRI (RIImm r) = pprImm r + +pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Unpretty + +pprRegRIReg name reg1 ri reg2 + = uppBesides [ + uppChar '\t', + uppPStr name, + uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty + +pprSizeRegRegReg name size reg1 reg2 reg3 + = uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppChar '\t', + pprReg reg1, + uppComma, + pprReg reg2, + uppComma, + pprReg reg3 + ] + +#endif {-alpha_TARGET_ARCH-} +\end{code} + +%************************************************************************ +%* * +\subsubsection{@pprInstr@ for an I386} +%* * +%************************************************************************ + +\begin{code} +#if i386_TARGET_ARCH + +pprInstr (MOV size (OpReg src) (OpReg dst)) -- hack + | src == dst + = uppPStr SLIT("") +pprInstr (MOV size src dst) + = pprSizeOpOp SLIT("mov") size src dst +pprInstr (MOVZX size src dst) = pprSizeOpOpCoerce SLIT("movzx") L size src dst +pprInstr (MOVSX size src dst) = pprSizeOpOpCoerce SLIT("movxs") L size src dst + +-- here we do some patching, since the physical registers are only set late +-- in the code generation. +pprInstr (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) + | reg1 == reg3 + = pprSizeOpOp SLIT("add") size (OpReg reg2) dst +pprInstr (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3)) + | reg2 == reg3 + = pprSizeOpOp SLIT("add") size (OpReg reg1) dst +pprInstr (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3)) + | reg1 == reg3 + = pprInstr (ADD size (OpImm displ) dst) +pprInstr (LEA size src dst) = pprSizeOpOp SLIT("lea") size src dst + +pprInstr (ADD size (OpImm (ImmInt (-1))) dst) + = pprSizeOp SLIT("dec") size dst +pprInstr (ADD size (OpImm (ImmInt 1)) dst) + = pprSizeOp SLIT("inc") size dst +pprInstr (ADD size src dst) + = pprSizeOpOp SLIT("add") size src dst +pprInstr (SUB size src dst) = pprSizeOpOp SLIT("sub") size src dst +pprInstr (IMUL size op1 op2) = pprSizeOpOp SLIT("imul") size op1 op2 +pprInstr (IDIV size op) = pprSizeOp SLIT("idiv") size op + +pprInstr (AND size src dst) = pprSizeOpOp SLIT("and") size src dst +pprInstr (OR size src dst) = pprSizeOpOp SLIT("or") size src dst +pprInstr (XOR size src dst) = pprSizeOpOp SLIT("xor") size src dst +pprInstr (NOT size op) = pprSizeOp SLIT("not") size op +pprInstr (NEGI size op) = pprSizeOp SLIT("neg") size op +pprInstr (SHL size imm dst) = pprSizeOpOp SLIT("shl") size imm dst +pprInstr (SAR size imm dst) = pprSizeOpOp SLIT("sar") size imm dst +pprInstr (SHR size imm dst) = pprSizeOpOp SLIT("shr") size imm dst + +pprInstr (CMP size src dst) = pprSizeOpOp SLIT("cmp") size src dst +pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst +pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op +pprInstr (POP size op) = pprSizeOp SLIT("pop") size op + +pprInstr (NOP) = uppPStr SLIT("\tnop") +pprInstr (CLTD) = uppPStr SLIT("\tcltd") + +pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op) + +pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab) + +pprInstr (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm imm) +pprInstr (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand L op) + +pprInstr (CALL imm) + = uppBesides [ uppPStr SLIT("\tcall "), pprImm imm ] + +pprInstr SAHF = uppPStr SLIT("\tsahf") +pprInstr FABS = uppPStr SLIT("\tfabs") + +pprInstr (FADD sz src@(OpAddr _)) + = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppSP, pprOperand sz src] +pprInstr (FADD sz src) + = uppPStr SLIT("\tfadd") +pprInstr FADDP + = uppPStr SLIT("\tfaddp") +pprInstr (FMUL sz src) + = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppSP, pprOperand sz src] +pprInstr FMULP + = uppPStr SLIT("\tfmulp") +pprInstr (FIADD size op) = pprSizeAddr SLIT("fiadd") size op +pprInstr FCHS = uppPStr SLIT("\tfchs") +pprInstr (FCOM size op) = pprSizeOp SLIT("fcom") size op +pprInstr FCOS = uppPStr SLIT("\tfcos") +pprInstr (FIDIV size op) = pprSizeAddr SLIT("fidiv") size op +pprInstr (FDIV sz src) + = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppSP, pprOperand sz src] +pprInstr FDIVP + = uppPStr SLIT("\tfdivp") +pprInstr (FDIVR sz src) + = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppSP, pprOperand sz src] +pprInstr FDIVRP + = uppPStr SLIT("\tfdivpr") +pprInstr (FIDIVR size op) = pprSizeAddr SLIT("fidivr") size op +pprInstr (FICOM size op) = pprSizeAddr SLIT("ficom") size op +pprInstr (FILD sz op reg) = pprSizeAddrReg SLIT("fild") sz op reg +pprInstr (FIST size op) = pprSizeAddr SLIT("fist") size op +pprInstr (FLD sz (OpImm (ImmCLbl src))) + = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprCLabel_asm src] +pprInstr (FLD sz src) + = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprOperand sz src] +pprInstr FLD1 = uppPStr SLIT("\tfld1") +pprInstr FLDZ = uppPStr SLIT("\tfldz") +pprInstr (FIMUL size op) = pprSizeAddr SLIT("fimul") size op +pprInstr FRNDINT = uppPStr SLIT("\tfrndint") +pprInstr FSIN = uppPStr SLIT("\tfsin") +pprInstr FSQRT = uppPStr SLIT("\tfsqrt") +pprInstr (FST sz dst) + = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppSP, pprOperand sz dst] +pprInstr (FSTP sz dst) + = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppSP, pprOperand sz dst] +pprInstr (FISUB size op) = pprSizeAddr SLIT("fisub") size op +pprInstr (FSUB sz src) + = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppSP, pprOperand sz src] +pprInstr FSUBP + = uppPStr SLIT("\tfsubp") +pprInstr (FSUBR size src) + = pprSizeOp SLIT("fsubr") size src +pprInstr FSUBRP + = uppPStr SLIT("\tfsubpr") +pprInstr (FISUBR size op) + = pprSizeAddr SLIT("fisubr") size op +pprInstr FTST = uppPStr SLIT("\tftst") +pprInstr (FCOMP sz op) + = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppSP, pprOperand sz op] +pprInstr FUCOMPP = uppPStr SLIT("\tfucompp") +pprInstr FXCH = uppPStr SLIT("\tfxch") +pprInstr FNSTSW = uppPStr SLIT("\tfnstsw %ax") +pprInstr FNOP = uppPStr SLIT("") +\end{code} + +Continue with I386-only printing bits and bobs: +\begin{code} +pprDollImm :: Imm -> Unpretty + +pprDollImm i = uppBesides [ uppPStr SLIT("$"), pprImm i] + +pprOperand :: Size -> Operand -> Unpretty +pprOperand s (OpReg r) = pprReg s r +pprOperand s (OpImm i) = pprDollImm i +pprOperand s (OpAddr ea) = pprAddr ea + +pprSizeOp :: FAST_STRING -> Size -> Operand -> Unpretty +pprSizeOp name size op1 + = uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppSP, + pprOperand size op1 + ] + +pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty +pprSizeOpOp name size op1 op2 + = uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppSP, + pprOperand size op1, + uppComma, + pprOperand size op2 + ] + +pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Unpretty +pprSizeOpReg name size op1 reg + = uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppSP, + pprOperand size op1, + uppComma, + pprReg size reg + ] + +pprSizeAddr :: FAST_STRING -> Size -> Addr -> Unpretty +pprSizeAddr name size op + = uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppSP, + pprAddr op + ] + +pprSizeAddrReg :: FAST_STRING -> Size -> Addr -> Reg -> Unpretty +pprSizeAddrReg name size op dst + = uppBesides [ + uppChar '\t', + uppPStr name, + pprSize size, + uppSP, + pprAddr op, + uppComma, + pprReg size dst + ] + +pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty +pprOpOp name size op1 op2 + = uppBesides [ + uppChar '\t', + uppPStr name, uppSP, + pprOperand size op1, + uppComma, + pprOperand size op2 + ] + +pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty +pprSizeOpOpCoerce name size1 size2 op1 op2 + = uppBesides [ uppChar '\t', uppPStr name, uppSP, + pprOperand size1 op1, + uppComma, + pprOperand size2 op2 + ] + +pprCondInstr :: FAST_STRING -> Cond -> Unpretty -> Unpretty +pprCondInstr name cond arg + = uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppSP, arg] + +#endif {-i386_TARGET_ARCH-} +\end{code} + +%************************************************************************ +%* * +\subsubsection{@pprInstr@ for a SPARC} +%* * +%************************************************************************ + +\begin{code} +#if sparc_TARGET_ARCH + +-- a clumsy hack for now, to handle possible double alignment problems + +pprInstr (LD DF addr reg) | maybeToBool off_addr + = uppBesides [ + pp_ld_lbracket, + pprAddr addr, + pp_rbracket_comma, + pprReg reg, + + uppChar '\n', + pp_ld_lbracket, + pprAddr addr2, + pp_rbracket_comma, + pprReg (fPair reg) + ] + where + off_addr = addrOffset addr 4 + addr2 = case off_addr of Just x -> x + +pprInstr (LD size addr reg) + = uppBesides [ + uppPStr SLIT("\tld"), + pprSize size, + uppChar '\t', + uppLbrack, + pprAddr addr, + pp_rbracket_comma, + pprReg reg + ] + +-- The same clumsy hack as above + +pprInstr (ST DF reg addr) | maybeToBool off_addr + = uppBesides [ + uppPStr SLIT("\tst\t"), + pprReg reg, + pp_comma_lbracket, + pprAddr addr, + + uppPStr SLIT("]\n\tst\t"), + pprReg (fPair reg), + pp_comma_lbracket, + pprAddr addr2, + uppRbrack + ] + where + off_addr = addrOffset addr 4 + addr2 = case off_addr of Just x -> x + +pprInstr (ST size reg addr) + = uppBesides [ + uppPStr SLIT("\tst"), + pprSize size, + uppChar '\t', + pprReg reg, + pp_comma_lbracket, + pprAddr addr, + uppRbrack + ] + +pprInstr (ADD x cc reg1 ri reg2) + | not x && not cc && riZero ri + = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ] + | otherwise + = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2 + +pprInstr (SUB x cc reg1 ri reg2) + | not x && cc && reg2 == g0 + = uppBesides [ uppPStr SLIT("\tcmp\t"), pprReg reg1, uppComma, pprRI ri ] + | not x && not cc && riZero ri + = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ] + | otherwise + = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2 + +pprInstr (AND b reg1 ri reg2) = pprRegRIReg SLIT("and") b reg1 ri reg2 +pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2 + +pprInstr (OR b reg1 ri reg2) + | not b && reg1 == g0 + = uppBesides [ uppPStr SLIT("\tmov\t"), pprRI ri, uppComma, pprReg reg2 ] + | otherwise + = pprRegRIReg SLIT("or") b reg1 ri reg2 + +pprInstr (ORN b reg1 ri reg2) = pprRegRIReg SLIT("orn") b reg1 ri reg2 + +pprInstr (XOR b reg1 ri reg2) = pprRegRIReg SLIT("xor") b reg1 ri reg2 +pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg SLIT("xnor") b reg1 ri reg2 + +pprInstr (SLL reg1 ri reg2) = pprRegRIReg SLIT("sll") False reg1 ri reg2 +pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2 +pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2 + +pprInstr (SETHI imm reg) + = uppBesides [ + uppPStr SLIT("\tsethi\t"), + pprImm imm, + uppComma, + pprReg reg + ] + +pprInstr NOP = uppPStr SLIT("\tnop") + +pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2 +pprInstr (FABS DF reg1 reg2) + = uppBeside (pprSizeRegReg SLIT("fabs") F reg1 reg2) + (if (reg1 == reg2) then uppNil + else uppBeside (uppChar '\n') + (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2))) + +pprInstr (FADD size reg1 reg2 reg3) + = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3 +pprInstr (FCMP e size reg1 reg2) + = pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2 +pprInstr (FDIV size reg1 reg2 reg3) + = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3 + +pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2 +pprInstr (FMOV DF reg1 reg2) + = uppBeside (pprSizeRegReg SLIT("fmov") F reg1 reg2) + (if (reg1 == reg2) then uppNil + else uppBeside (uppChar '\n') + (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2))) + +pprInstr (FMUL size reg1 reg2 reg3) + = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3 + +pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2 +pprInstr (FNEG DF reg1 reg2) + = uppBeside (pprSizeRegReg SLIT("fneg") F reg1 reg2) + (if (reg1 == reg2) then uppNil + else uppBeside (uppChar '\n') + (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2))) + +pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2 +pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3 +pprInstr (FxTOy size1 size2 reg1 reg2) + = uppBesides [ + uppPStr SLIT("\tf"), + uppPStr + (case size1 of + W -> SLIT("ito") + F -> SLIT("sto") + DF -> SLIT("dto")), + uppPStr + (case size2 of + W -> SLIT("i\t") + F -> SLIT("s\t") + DF -> SLIT("d\t")), + pprReg reg1, uppComma, pprReg reg2 + ] + + +pprInstr (BI cond b lab) + = uppBesides [ + uppPStr SLIT("\tb"), pprCond cond, + if b then pp_comma_a else uppNil, + uppChar '\t', + pprImm lab + ] + +pprInstr (BF cond b lab) + = uppBesides [ + uppPStr SLIT("\tfb"), pprCond cond, + if b then pp_comma_a else uppNil, + uppChar '\t', + pprImm lab + ] + +pprInstr (JMP addr) = uppBeside (uppPStr SLIT("\tjmp\t")) (pprAddr addr) + +pprInstr (CALL imm n _) + = uppBesides [ uppPStr SLIT("\tcall\t"), pprImm imm, uppComma, uppInt n ] +\end{code} + +Continue with SPARC-only printing bits and bobs: +\begin{code} +pprRI :: RI -> Unpretty +pprRI (RIReg r) = pprReg r +pprRI (RIImm r) = pprImm r + +pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Unpretty +pprSizeRegReg name size reg1 reg2 + = uppBesides [ + uppChar '\t', + uppPStr name, + (case size of + F -> uppPStr SLIT("s\t") + DF -> uppPStr SLIT("d\t")), + pprReg reg1, + uppComma, + pprReg reg2 + ] + +pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty +pprSizeRegRegReg name size reg1 reg2 reg3 + = uppBesides [ + uppChar '\t', + uppPStr name, + (case size of + F -> uppPStr SLIT("s\t") + DF -> uppPStr SLIT("d\t")), + pprReg reg1, + uppComma, + pprReg reg2, + uppComma, + pprReg reg3 + ] + +pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Unpretty +pprRegRIReg name b reg1 ri reg2 + = uppBesides [ + uppChar '\t', + uppPStr name, + if b then uppPStr SLIT("cc\t") else uppChar '\t', + pprReg reg1, + uppComma, + pprRI ri, + uppComma, + pprReg reg2 + ] + +pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Unpretty +pprRIReg name b ri reg1 + = uppBesides [ + uppChar '\t', + uppPStr name, + if b then uppPStr SLIT("cc\t") else uppChar '\t', + pprRI ri, + uppComma, + pprReg reg1 + ] + +pp_ld_lbracket = uppPStr (_packCString (A# "\tld\t["#)) +pp_rbracket_comma = uppPStr (_packCString (A# "],"#)) +pp_comma_lbracket = uppPStr (_packCString (A# ",["#)) +pp_comma_a = uppPStr (_packCString (A# ",a"#)) + +#endif {-sparc_TARGET_ARCH-} +\end{code} diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs new file mode 100644 index 0000000..93cda5c --- /dev/null +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -0,0 +1,799 @@ +% +% (c) The AQUA Project, Glasgow University, 1996 +% +\section[RegAllocInfo]{Machine-specific info used for register allocation} + +The (machine-independent) allocator itself is in @AsmRegAlloc@. + +\begin{code} +#include "HsVersions.h" +#include "nativeGen/NCG.h" + +module RegAllocInfo ( + MRegsState(..), + mkMRegsState, + freeMReg, + freeMRegs, + possibleMRegs, + useMReg, + useMRegs, + + RegUsage(..), + noUsage, + endUsage, + regUsage, + + FutureLive(..), + RegAssignment(..), + RegConflicts(..), + RegFuture(..), + RegHistory(..), + RegInfo(..), + RegLiveness(..), + + fstFL, + loadReg, + patchRegs, + regLiveness, + spillReg, + + RegSet(..), + elementOfRegSet, + emptyRegSet, + isEmptyRegSet, + minusRegSet, + mkRegSet, + regSetToList, + unionRegSets, + + argRegSet, + callClobberedRegSet, + freeRegSet + ) where + +import Ubiq{-uitous-} + +import MachMisc +import MachRegs +import MachCode ( InstrList(..) ) + +import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet ) +import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} ) +import FiniteMap ( addToFM, lookupFM ) +import OrdList ( mkUnitList, OrdList ) +import PrimRep ( PrimRep(..) ) +import Stix ( StixTree, CodeSegment ) +import UniqSet -- quite a bit of it +import Unpretty ( uppShow ) +\end{code} + +%************************************************************************ +%* * +\subsection{Register allocation information} +%* * +%************************************************************************ + +\begin{code} +type RegSet = UniqSet Reg + +mkRegSet :: [Reg] -> RegSet +emptyRegSet :: RegSet +unionRegSets, minusRegSet :: RegSet -> RegSet -> RegSet +elementOfRegSet :: Reg -> RegSet -> Bool +isEmptyRegSet :: RegSet -> Bool +regSetToList :: RegSet -> [Reg] + +mkRegSet = mkUniqSet +emptyRegSet = emptyUniqSet +unionRegSets = unionUniqSets +minusRegSet = minusUniqSet +elementOfRegSet = elementOfUniqSet +isEmptyRegSet = isEmptyUniqSet +regSetToList = uniqSetToList + +freeRegSet, callClobberedRegSet :: RegSet +argRegSet :: Int -> RegSet + +freeRegSet = mkRegSet freeRegs +callClobberedRegSet = mkRegSet callClobberedRegs +argRegSet n = mkRegSet (argRegs n) + +type RegAssignment = FiniteMap Reg Reg +type RegConflicts = FiniteMap Int RegSet + +data FutureLive = FL RegSet (FiniteMap CLabel RegSet) + +fstFL (FL a b) = a + +data RegHistory a + = RH a + Int + RegAssignment + +data RegFuture + = RF RegSet -- in use + FutureLive -- future + RegConflicts + +data RegInfo a + = RI RegSet -- in use + RegSet -- sources + RegSet -- destinations + [Reg] -- last used + RegConflicts +\end{code} + +%************************************************************************ +%* * +\subsection{Register allocation information} +%* * +%************************************************************************ + +COMMENT ON THE EXTRA BitSet FOR SPARC MRegsState: 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 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 sets: one for single precision and one for double precision. We +never seem to run out of floating point registers anyway. + +\begin{code} +data MRegsState + = MRs BitSet -- integer registers + BitSet -- floating-point registers + IF_ARCH_sparc(BitSet,) -- double registers handled separately +\end{code} + +\begin{code} +#if alpha_TARGET_ARCH +# define INT_FLPT_CUTOFF 32 +#endif +#if i386_TARGET_ARCH +# define INT_FLPT_CUTOFF 8 +#endif +#if sparc_TARGET_ARCH +# define INT_FLPT_CUTOFF 32 +# define SNGL_DBL_CUTOFF 48 +#endif + +mkMRegsState :: [RegNo] -> MRegsState +possibleMRegs :: PrimRep -> MRegsState -> [RegNo] +useMReg :: MRegsState -> FAST_REG_NO -> MRegsState +useMRegs :: MRegsState -> [RegNo] -> MRegsState +freeMReg :: MRegsState -> FAST_REG_NO -> MRegsState +freeMRegs :: MRegsState -> [RegNo] -> MRegsState + +mkMRegsState xs + = MRs (mkBS is) (mkBS fs2) IF_ARCH_sparc((mkBS ds2),) + where + (is, fs) = partition (< INT_FLPT_CUTOFF) xs +#if sparc_TARGET_ARCH + (ss, ds) = partition (< SNGL_DBL_CUTOFF) fs + fs2 = map (subtract INT_FLPT_CUTOFF) ss + ds2 = map (subtract INT_FLPT_CUTOFF) (filter even ds) +#else + fs2 = map (subtract INT_FLPT_CUTOFF) fs +#endif + +------------------------------------------------ +#if sparc_TARGET_ARCH +possibleMRegs FloatRep (MRs _ ss _) = [ x + INT_FLPT_CUTOFF | x <- listBS ss] +possibleMRegs DoubleRep (MRs _ _ ds) = [ x + INT_FLPT_CUTOFF | x <- listBS ds] +possibleMRegs _ (MRs is _ _) = listBS is +#else +possibleMRegs FloatRep (MRs _ fs) = [ x + INT_FLPT_CUTOFF | x <- listBS fs] +possibleMRegs DoubleRep (MRs _ fs) = [ x + INT_FLPT_CUTOFF | x <- listBS fs] +possibleMRegs _ (MRs is _) = listBS is +#endif + +------------------------------------------------ +#if sparc_TARGET_ARCH +useMReg (MRs is ss ds) n + = if (n _LT_ ILIT(INT_FLPT_CUTOFF)) then + MRs (is `minusBS` unitBS IBOX(n)) ss ds + else if (n _LT_ ILIT(SNGL_DBL_CUTOFF)) then + MRs is (ss `minusBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) ds + else + MRs is ss (ds `minusBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) +#else +useMReg (MRs is fs) n + = if (n _LT_ ILIT(INT_FLPT_CUTOFF)) + then MRs (is `minusBS` unitBS IBOX(n)) fs + else MRs is (fs `minusBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) +#endif + +------------------------------------------------ +#if sparc_TARGET_ARCH +useMRegs (MRs is ss ds) xs + = MRs (is `minusBS` is2) (ss `minusBS` ss2) (ds `minusBS` ds2) + where + MRs is2 ss2 ds2 = mkMRegsState xs +#else +useMRegs (MRs is fs) xs + = MRs (is `minusBS` is2) (fs `minusBS` fs2) + where + MRs is2 fs2 = mkMRegsState xs +#endif + +------------------------------------------------ +#if sparc_TARGET_ARCH +freeMReg (MRs is ss ds) n + = if (n _LT_ ILIT(INT_FLPT_CUTOFF)) then + MRs (is `unionBS` unitBS IBOX(n)) ss ds + else if (n _LT_ ILIT(SNGL_DBL_CUTOFF)) then + MRs is (ss `unionBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) ds + else + MRs is ss (ds `unionBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) +#else +freeMReg (MRs is fs) n + = if (n _LT_ ILIT(INT_FLPT_CUTOFF)) + then MRs (is `unionBS` unitBS IBOX(n)) fs + else MRs is (fs `unionBS` unitBS (IBOX(n _SUB_ ILIT(INT_FLPT_CUTOFF)))) +#endif + +------------------------------------------------ +#if sparc_TARGET_ARCH +freeMRegs (MRs is ss ds) xs + = MRs (is `unionBS` is2) (ss `unionBS` ss2) (ds `unionBS` ds2) + where + MRs is2 ss2 ds2 = mkMRegsState xs +#else +freeMRegs (MRs is fs) xs + = MRs (is `unionBS` is2) (fs `unionBS` fs2) + where + MRs is2 fs2 = mkMRegsState xs +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{@RegUsage@ type; @noUsage@, @endUsage@, @regUsage@ functions} +%* * +%************************************************************************ + +@regUsage@ returns the sets of src and destination registers used by a +particular instruction. Machine registers that are pre-allocated to +stgRegs are filtered out, because they are uninteresting from a +register allocation standpoint. (We wouldn't want them to end up on +the free list!) + +An important point: The @regUsage@ function for a particular +assembly language must not refer to fixed registers, such as Hp, SpA, +etc. The source and destination MRegsStates should only refer to +dynamically allocated registers or static registers from the free +list. As far as we are concerned, the fixed registers simply don't +exist (for allocation purposes, anyway). + +\begin{code} +data RegUsage = RU RegSet RegSet + +noUsage, endUsage :: RegUsage +noUsage = RU emptyRegSet emptyRegSet +endUsage = RU emptyRegSet freeRegSet + +regUsage :: Instr -> RegUsage + +#if alpha_TARGET_ARCH + +regUsage instr = case instr of + LD B reg addr -> usage (regAddr addr, [reg, t9]) + LD BU reg addr -> usage (regAddr addr, [reg, t9]) +-- LD W reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED +-- LD WU reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED + LD sz reg addr -> usage (regAddr addr, [reg]) + LDA reg addr -> usage (regAddr addr, [reg]) + LDAH reg addr -> usage (regAddr addr, [reg]) + LDGP reg addr -> usage (regAddr addr, [reg]) + LDI sz reg imm -> usage ([], [reg]) + ST B reg addr -> usage (reg : regAddr addr, [t9, t10]) +-- ST W reg addr -> usage (reg : regAddr addr, [t9, t10]) : UNUSED + ST sz reg addr -> usage (reg : regAddr addr, []) + CLR reg -> usage ([], [reg]) + ABS sz ri reg -> usage (regRI ri, [reg]) + NEG sz ov ri reg -> usage (regRI ri, [reg]) + ADD sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SADD sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SUB sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SSUB sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2]) + MUL sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) + DIV sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12]) + REM sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12]) + NOT ri reg -> usage (regRI ri, [reg]) + AND r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ANDNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) + OR r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XOR r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ZAP r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ZAPNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) + CMP co r1 ar r2 -> usage (r1 : regRI ar, [r2]) + FCLR reg -> usage ([], [reg]) + FABS r1 r2 -> usage ([r1], [r2]) + FNEG sz r1 r2 -> usage ([r1], [r2]) + FADD sz r1 r2 r3 -> usage ([r1, r2], [r3]) + FDIV sz r1 r2 r3 -> usage ([r1, r2], [r3]) + FMUL sz r1 r2 r3 -> usage ([r1, r2], [r3]) + FSUB sz r1 r2 r3 -> usage ([r1, r2], [r3]) + CVTxy sz1 sz2 r1 r2 -> usage ([r1], [r2]) + FCMP sz co r1 r2 r3 -> usage ([r1, r2], [r3]) + FMOV r1 r2 -> usage ([r1], [r2]) + + + -- We assume that all local jumps will be BI/BF/BR. JMP must be out-of-line. + BI cond reg lbl -> usage ([reg], []) + BF cond reg lbl -> usage ([reg], []) + JMP reg addr hint -> RU (mkRegSet (filter interesting (regAddr addr))) freeRegSet + + BSR _ n -> RU (argRegSet n) callClobberedRegSet + JSR reg addr n -> RU (argRegSet n) callClobberedRegSet + + _ -> noUsage + + where + usage (src, dst) = RU (mkRegSet (filter interesting src)) + (mkRegSet (filter interesting dst)) + + interesting (FixedReg _) = False + interesting _ = True + + regAddr (AddrReg r1) = [r1] + regAddr (AddrRegImm r1 _) = [r1] + regAddr (AddrImm _) = [] + + regRI (RIReg r) = [r] + regRI _ = [] + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +regUsage instr = case instr of + MOV sz src dst -> usage2 src dst + MOVZX sz src dst -> usage2 src dst + MOVSX sz src dst -> usage2 src dst + LEA sz src dst -> usage2 src dst + ADD sz src dst -> usage2 src dst + SUB sz src dst -> usage2 src dst + IMUL sz src dst -> usage2 src dst + IDIV sz src -> usage (eax:edx:opToReg src) [eax,edx] + AND sz src dst -> usage2 src dst + OR sz src dst -> usage2 src dst + XOR sz src dst -> usage2 src dst + NOT sz op -> usage1 op + NEGI sz op -> usage1 op + SHL sz imm dst -> usage1 dst -- imm has to be an Imm + SAR sz imm dst -> usage1 dst -- imm has to be an Imm + SHR sz imm dst -> usage1 dst -- imm has to be an Imm + PUSH sz op -> usage (opToReg op) [] + POP sz op -> usage [] (opToReg op) + TEST sz src dst -> usage (opToReg src ++ opToReg dst) [] + CMP sz src dst -> usage (opToReg src ++ opToReg dst) [] + SETCC cond op -> usage [] (opToReg op) + JXX cond label -> usage [] [] + JMP op -> usage (opToReg op) freeRegs + CALL imm -> usage [] callClobberedRegs + CLTD -> usage [eax] [edx] + NOP -> usage [] [] + SAHF -> usage [eax] [] + FABS -> usage [st0] [st0] + FADD sz src -> usage (st0:opToReg src) [st0] -- allFPRegs + FADDP -> usage [st0,st1] [st0] -- allFPRegs + FIADD sz asrc -> usage (addrToRegs asrc) [st0] + FCHS -> usage [st0] [st0] + FCOM sz src -> usage (st0:opToReg src) [] + FCOS -> usage [st0] [st0] + FDIV sz src -> usage (st0:opToReg src) [st0] + FDIVP -> usage [st0,st1] [st0] + FDIVRP -> usage [st0,st1] [st0] + FIDIV sz asrc -> usage (addrToRegs asrc) [st0] + FDIVR sz src -> usage (st0:opToReg src) [st0] + FIDIVR sz asrc -> usage (addrToRegs asrc) [st0] + FICOM sz asrc -> usage (addrToRegs asrc) [] + FILD sz asrc dst -> usage (addrToRegs asrc) [dst] -- allFPRegs + FIST sz adst -> usage (st0:addrToRegs adst) [] + FLD sz src -> usage (opToReg src) [st0] -- allFPRegs + FLD1 -> usage [] [st0] -- allFPRegs + FLDZ -> usage [] [st0] -- allFPRegs + FMUL sz src -> usage (st0:opToReg src) [st0] + FMULP -> usage [st0,st1] [st0] + FIMUL sz asrc -> usage (addrToRegs asrc) [st0] + FRNDINT -> usage [st0] [st0] + FSIN -> usage [st0] [st0] + FSQRT -> usage [st0] [st0] + FST sz (OpReg r) -> usage [st0] [r] + FST sz dst -> usage (st0:opToReg dst) [] + FSTP sz (OpReg r) -> usage [st0] [r] -- allFPRegs + FSTP sz dst -> usage (st0:opToReg dst) [] -- allFPRegs + FSUB sz src -> usage (st0:opToReg src) [st0] -- allFPRegs + FSUBR sz src -> usage (st0:opToReg src) [st0] -- allFPRegs + FISUB sz asrc -> usage (addrToRegs asrc) [st0] + FSUBP -> usage [st0,st1] [st0] -- allFPRegs + FSUBRP -> usage [st0,st1] [st0] -- allFPRegs + FISUBR sz asrc -> usage (addrToRegs asrc) [st0] + FTST -> usage [st0] [] + FCOMP sz op -> usage (st0:opToReg op) [st0] -- allFPRegs + FUCOMPP -> usage [st0, st1] [] -- allFPRegs + FXCH -> usage [st0, st1] [st0, st1] + FNSTSW -> usage [] [eax] + _ -> noUsage + where + usage2 :: Operand -> Operand -> RegUsage + usage2 op (OpReg reg) = usage (opToReg op) [reg] + usage2 op (OpAddr ea) = usage (opToReg op ++ addrToRegs ea) [] + usage2 op (OpImm imm) = usage (opToReg op) [] + usage1 :: Operand -> RegUsage + usage1 (OpReg reg) = usage [reg] [reg] + 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] + +-- General purpose register collecting functions. + + opToReg (OpReg reg) = [reg] + opToReg (OpImm imm) = [] + opToReg (OpAddr ea) = addrToRegs ea + + addrToRegs (Addr base index _) = baseToReg base ++ indexToReg index + where baseToReg Nothing = [] + baseToReg (Just r) = [r] + indexToReg Nothing = [] + indexToReg (Just (r,_)) = [r] + addrToRegs (ImmAddr _ _) = [] + + usage src dst = RU (mkRegSet (filter interesting src)) + (mkRegSet (filter interesting dst)) + + interesting (FixedReg _) = False + interesting _ = True + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +regUsage instr = case instr of + LD sz addr reg -> usage (regAddr addr, [reg]) + ST sz reg addr -> usage (reg : regAddr addr, []) + ADD x cc r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SUB x cc r1 ar r2 -> usage (r1 : regRI ar, [r2]) + AND b r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ANDN b r1 ar r2 -> usage (r1 : regRI ar, [r2]) + OR b r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ORN b r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XOR b r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XNOR b r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SETHI imm reg -> usage ([], [reg]) + FABS s r1 r2 -> usage ([r1], [r2]) + FADD s r1 r2 r3 -> usage ([r1, r2], [r3]) + FCMP e s r1 r2 -> usage ([r1, r2], []) + FDIV s r1 r2 r3 -> usage ([r1, r2], [r3]) + FMOV s r1 r2 -> usage ([r1], [r2]) + FMUL s r1 r2 r3 -> usage ([r1, r2], [r3]) + FNEG s r1 r2 -> usage ([r1], [r2]) + FSQRT s r1 r2 -> usage ([r1], [r2]) + FSUB s r1 r2 r3 -> usage ([r1, r2], [r3]) + FxTOy s1 s2 r1 r2 -> usage ([r1], [r2]) + + -- We assume that all local jumps will be BI/BF. JMP must be out-of-line. + JMP addr -> RU (mkRegSet (filter interesting (regAddr addr))) freeRegSet + + CALL _ n True -> endUsage + CALL _ n False -> RU (argRegSet n) callClobberedRegSet + + _ -> noUsage + where + usage (src, dst) = RU (mkRegSet (filter interesting src)) + (mkRegSet (filter interesting dst)) + + interesting (FixedReg _) = False + interesting _ = True + + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + + regRI (RIReg r) = [r] + regRI _ = [] + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{@RegLiveness@ type; @regLiveness@ function} +%* * +%************************************************************************ + +@regLiveness@ takes future liveness information and modifies it +according to the semantics of branches and labels. (An out-of-line +branch clobbers the liveness passed back by the following instruction; +a forward local branch passes back the liveness from the target label; +a conditional branch merges the liveness from the target and the +liveness from its successor; a label stashes away the current liveness +in the future liveness environment). + +\begin{code} +data RegLiveness = RL RegSet FutureLive + +regLiveness :: Instr -> RegLiveness -> RegLiveness + +regLiveness instr info@(RL live future@(FL all env)) + = let + lookup lbl + = case (lookupFM env lbl) of + Just rs -> rs + Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel_asm lbl)) ++ + " in future?") emptyRegSet + in + case instr of -- the rest is machine-specific... + +#if alpha_TARGET_ARCH + + -- We assume that all local jumps will be BI/BF. JMP must be out-of-line. + + BR (ImmCLbl lbl) -> RL (lookup lbl) future + BI _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionRegSets` live) future + BF _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionRegSets` live) future + JMP _ _ _ -> RL emptyRegSet future + BSR _ _ -> RL live future + JSR _ _ _ -> RL live future + LABEL lbl -> RL live (FL (all `unionRegSets` live) (addToFM env lbl live)) + _ -> info + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + + JXX _ lbl -> RL (lookup lbl `unionRegSets` live) future + JMP _ -> RL emptyRegSet future + CALL _ -> RL live future + LABEL lbl -> RL live (FL (all `unionRegSets` live) (addToFM env lbl live)) + _ -> info + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + + -- We assume that all local jumps will be BI/BF. JMP must be out-of-line. + + BI ALWAYS _ (ImmCLbl lbl) -> RL (lookup lbl) future + BI _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionRegSets` live) future + BF ALWAYS _ (ImmCLbl lbl) -> RL (lookup lbl) future + BF _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionRegSets` live) future + JMP _ -> RL emptyRegSet future + CALL _ i True -> RL emptyRegSet future + CALL _ i False -> RL live future + LABEL lbl -> RL live (FL (all `unionRegSets` live) (addToFM env lbl live)) + _ -> info + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{@patchRegs@ function} +%* * +%************************************************************************ + +@patchRegs@ takes an instruction (possibly with +MemoryReg/UnmappedReg registers) and changes all register references +according to the supplied environment. + +\begin{code} +patchRegs :: Instr -> (Reg -> Reg) -> Instr + +#if alpha_TARGET_ARCH + +patchRegs instr env = case instr of + LD sz reg addr -> LD sz (env reg) (fixAddr addr) + LDA reg addr -> LDA (env reg) (fixAddr addr) + LDAH reg addr -> LDAH (env reg) (fixAddr addr) + LDGP reg addr -> LDGP (env reg) (fixAddr addr) + LDI sz reg imm -> LDI sz (env reg) imm + ST sz reg addr -> ST sz (env reg) (fixAddr addr) + CLR reg -> CLR (env reg) + ABS sz ar reg -> ABS sz (fixRI ar) (env reg) + NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg) + ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2) + SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2) + SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2) + SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2) + MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2) + DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2) + REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2) + NOT ar reg -> NOT (fixRI ar) (env reg) + AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2) + ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2) + OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2) + ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2) + XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2) + XORNOT r1 ar r2 -> XORNOT (env r1) (fixRI ar) (env r2) + SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) + SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) + SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) + ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2) + ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2) + CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2) + FCLR reg -> FCLR (env reg) + FABS r1 r2 -> FABS (env r1) (env r2) + FNEG s r1 r2 -> FNEG s (env r1) (env r2) + FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) + FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) + FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) + FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) + CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2) + FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3) + FMOV r1 r2 -> FMOV (env r1) (env r2) + BI cond reg lbl -> BI cond (env reg) lbl + BF cond reg lbl -> BF cond (env reg) lbl + JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint + JSR reg addr i -> JSR (env reg) (fixAddr addr) i + _ -> instr + where + fixAddr (AddrReg r1) = AddrReg (env r1) + fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + fixAddr other = other + + fixRI (RIReg r) = RIReg (env r) + fixRI other = other + +#endif {- alpha_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if i386_TARGET_ARCH + +patchRegs instr env = case instr of + MOV sz src dst -> patch2 (MOV sz) src dst + MOVZX sz src dst -> patch2 (MOVZX sz) src dst + MOVSX sz src dst -> patch2 (MOVSX sz) src dst + LEA sz src dst -> patch2 (LEA sz) src dst + 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 + 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 + NOT sz op -> patch1 (NOT sz) op + NEGI sz op -> patch1 (NEGI sz) op + SHL sz imm dst -> patch1 (SHL sz imm) dst + SAR sz imm dst -> patch1 (SAR sz imm) dst + SHR sz imm dst -> patch1 (SHR sz imm) dst + TEST sz src dst -> patch2 (TEST sz) src dst + CMP sz src dst -> patch2 (CMP sz) src dst + PUSH sz op -> patch1 (PUSH sz) op + POP sz op -> patch1 (POP sz) op + SETCC cond op -> patch1 (SETCC cond) op + JMP op -> patch1 JMP op + FADD sz src -> FADD sz (patchOp src) + FIADD sz asrc -> FIADD sz (lookupAddr asrc) + FCOM sz src -> patch1 (FCOM sz) src + FDIV sz src -> FDIV sz (patchOp src) + --FDIVP sz src -> FDIVP sz (patchOp src) + FIDIV sz asrc -> FIDIV sz (lookupAddr asrc) + FDIVR sz src -> FDIVR sz (patchOp src) + --FDIVRP sz src -> FDIVRP sz (patchOp src) + FIDIVR sz asrc -> FIDIVR sz (lookupAddr asrc) + FICOM sz asrc -> FICOM sz (lookupAddr asrc) + FILD sz asrc dst -> FILD sz (lookupAddr asrc) (env dst) + FIST sz adst -> FIST sz (lookupAddr adst) + FLD sz src -> patch1 (FLD sz) (patchOp src) + FMUL sz src -> FMUL sz (patchOp src) + --FMULP sz src -> FMULP sz (patchOp src) + FIMUL sz asrc -> FIMUL sz (lookupAddr asrc) + FST sz dst -> FST sz (patchOp dst) + FSTP sz dst -> FSTP sz (patchOp dst) + FSUB sz src -> FSUB sz (patchOp src) + --FSUBP sz src -> FSUBP sz (patchOp src) + FISUB sz asrc -> FISUB sz (lookupAddr asrc) + FSUBR sz src -> FSUBR sz (patchOp src) + --FSUBRP sz src -> FSUBRP sz (patchOp src) + 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 (OpReg reg) = OpReg (env reg) + patchOp (OpImm imm) = OpImm imm + patchOp (OpAddr ea) = OpAddr (lookupAddr ea) + + lookupAddr (ImmAddr imm off) = ImmAddr imm off + 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) + +#endif {- i386_TARGET_ARCH -} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +#if sparc_TARGET_ARCH + +patchRegs instr env = case instr of + LD sz addr reg -> LD sz (fixAddr addr) (env reg) + ST sz reg addr -> ST sz (env reg) (fixAddr addr) + ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) + SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) + AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) + ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) + OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) + ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) + XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) + XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) + SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) + SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) + SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) + SETHI imm reg -> SETHI imm (env reg) + FABS s r1 r2 -> FABS s (env r1) (env r2) + FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) + FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) + FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) + FMOV s r1 r2 -> FMOV s (env r1) (env r2) + FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) + FNEG s r1 r2 -> FNEG s (env r1) (env r2) + FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) + FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) + FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) + JMP addr -> JMP (fixAddr addr) + _ -> instr + where + fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + + fixRI (RIReg r) = RIReg (env r) + fixRI other = other + +#endif {- sparc_TARGET_ARCH -} +\end{code} + +%************************************************************************ +%* * +\subsection{@spillReg@ and @loadReg@ functions} +%* * +%************************************************************************ + +Spill to memory, and load it back... + +\begin{code} +spillReg, loadReg :: Reg -> Reg -> InstrList + +spillReg dyn (MemoryReg i pk) + = let + sz = primRepToSize pk + in + mkUnitList ( + {-Alpha: spill below the stack pointer (?)-} + IF_ARCH_alpha( ST sz dyn (spRel i) + + {-I386: spill below stack pointer leaving 2 words/spill-} + ,IF_ARCH_i386 ( MOV sz (OpReg dyn) (OpAddr (spRel (-2 * i))) + + {-SPARC: spill below frame pointer leaving 2 words/spill-} + ,IF_ARCH_sparc( ST sz dyn (fpRel (-2 * i)) + ,))) + ) + +---------------------------- +loadReg (MemoryReg i pk) dyn + = let + sz = primRepToSize pk + in + mkUnitList ( + IF_ARCH_alpha( LD sz dyn (spRel i) + ,IF_ARCH_i386 ( MOV sz (OpAddr (spRel (-2 * i))) (OpReg dyn) + ,IF_ARCH_sparc( LD sz (fpRel (-2 * i)) dyn + ,))) + ) +\end{code} diff --git a/ghc/compiler/nativeGen/SparcCode.lhs b/ghc/compiler/nativeGen/SparcCode.lhs deleted file mode 100644 index 203807e..0000000 --- a/ghc/compiler/nativeGen/SparcCode.lhs +++ /dev/null @@ -1,1389 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1995 -% - -\section[SparcCode]{The Native (Sparc) Machine Code} - -\begin{code} -#define ILIT2(x) ILIT(x) -#include "HsVersions.h" - -module SparcCode ( - Addr(..),Cond(..),Imm(..),RI(..),Size(..), - SparcCode(..),SparcInstr(..),SparcRegs, - strImmLit, - - printLabeledCodes, - - baseRegOffset, stgRegMap, callerSaves, - - is13Bits, offset, - - kindToSize, - - g0, o0, f0, fp, sp, argRegs, - - freeRegs, reservedRegs - - -- and, for self-sufficiency ... - ) where - -IMPORT_Trace - -import AbsCSyn ( MagicId(..) ) -import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..), - Reg(..), RegUsage(..), RegLiveness(..) - ) -import BitSet -import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG ) -import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, charToC ) -import FiniteMap -import Maybes ( Maybe(..), maybeToBool ) -import OrdList ( OrdList, mkUnitList, flattenOrdList ) -import Outputable -import UniqSet -import Stix -import Unpretty -import Util -\end{code} - -%************************************************************************ -%* * -\subsection[SparcReg]{The Native (Sparc) Machine Register Table} -%* * -%************************************************************************ - -The sparc has 64 registers of interest; 32 integer registers and 32 floating -point registers. The mapping of STG registers to sparc machine registers -is defined in StgRegs.h. We are, of course, prepared for any eventuality. - -ToDo: Deal with stg registers that live as offsets from BaseReg!(JSM) - -\begin{code} - -gReg,lReg,iReg,oReg,fReg :: Int -> Int -gReg x = x -oReg x = (8 + x) -lReg x = (16 + x) -iReg x = (24 + x) -fReg x = (32 + x) - -fPair :: Reg -> Reg -fPair (FixedReg i) = FixedReg (i _ADD_ ILIT(1)) -fPair (MappedReg i) = MappedReg (i _ADD_ ILIT(1)) - -g0, fp, sp, o0, f0 :: Reg -g0 = case (gReg 0) of { IBOX(g0) -> FixedReg g0 } -fp = case (iReg 6) of { IBOX(i6) -> FixedReg i6 } -sp = case (oReg 6) of { IBOX(o6) -> FixedReg o6 } -o0 = realReg (oReg 0) -f0 = realReg (fReg 0) - -argRegs :: [Reg] -argRegs = map realReg [oReg i | i <- [0..5]] - -realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i - -\end{code} - -%************************************************************************ -%* * -\subsection[TheSparcCode]{The datatype for sparc assembly language} -%* * -%************************************************************************ - -Here is a definition of the Sparc assembly language. - -\begin{code} - -data Imm = ImmInt Int - | ImmInteger Integer -- Sigh. - | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLab Unpretty -- Simple string label (underscored) - | ImmLit Unpretty -- Simple string - | LO Imm -- Possible restrictions - | HI Imm - deriving () - -strImmLit s = ImmLit (uppStr s) - -data Addr = AddrRegReg Reg Reg - | AddrRegImm Reg Imm - deriving () - -data Cond = ALWAYS - | NEVER - | GEU - | LU - | EQ - | GT - | GE - | GU - | LT - | LE - | LEU - | NE - | NEG - | POS - | VC - | VS - deriving () - -data RI = RIReg Reg - | RIImm Imm - deriving () - -riZero :: RI -> Bool -riZero (RIImm (ImmInt 0)) = True -riZero (RIImm (ImmInteger 0)) = True -riZero (RIReg (FixedReg ILIT(0))) = True -riZero _ = False - -data Size = SB - | HW - | UB - | UHW - | W - | D - | F - | DF - deriving () - -data SparcInstr = - --- Loads and stores. - - LD Size Addr Reg -- size, src, dst - | ST Size Reg Addr -- size, src, dst - --- Int Arithmetic. - - | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - --- Simple bit-twiddling. - - | AND Bool Reg RI Reg -- cc?, src1, src2, dst - | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst - | OR Bool Reg RI Reg -- cc?, src1, src2, dst - | ORN Bool Reg RI Reg -- cc?, src1, src2, dst - | XOR Bool Reg RI Reg -- cc?, src1, src2, dst - | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst - | SLL Reg RI Reg -- src1, src2, dst - | SRL Reg RI Reg -- src1, src2, dst - | SRA Reg RI Reg -- src1, src2, dst - | SETHI Imm Reg -- src, dst - | NOP -- Really SETHI 0, %g0, but worth an alias - --- Float Arithmetic. - --- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions --- right up until we spit them out. - - | FABS Size Reg Reg -- src dst - | FADD Size Reg Reg Reg -- src1, src2, dst - | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst - | FDIV Size Reg Reg Reg -- src1, src2, dst - | FMOV Size Reg Reg -- src, dst - | FMUL Size Reg Reg Reg -- src1, src2, dst - | FNEG Size Reg Reg -- src, dst - | FSQRT Size Reg Reg -- src, dst - | FSUB Size Reg Reg Reg -- src1, src2, dst - | FxTOy Size Size Reg Reg -- src, dst - --- Jumping around. - - | BI Cond Bool Imm -- cond, annul?, target - | BF Cond Bool Imm -- cond, annul?, target - - | JMP Addr -- target - | CALL Imm Int Bool -- target, args, terminal - --- Pseudo-ops. - - | LABEL CLabel - | COMMENT FAST_STRING - | SEGMENT CodeSegment - | ASCII Bool String -- needs backslash conversion? - | DATA Size [Imm] - -type SparcCode = OrdList SparcInstr - -\end{code} - -%************************************************************************ -%* * -\subsection[TheSparcPretty]{Pretty-printing the Sparc Assembly Language} -%* * -%************************************************************************ - -\begin{code} - -printLabeledCodes :: PprStyle -> [SparcInstr] -> Unpretty -printLabeledCodes sty codes = uppAboves (map (pprSparcInstr sty) codes) - -\end{code} - -Printing the pieces... - -\begin{code} - -pprReg :: Reg -> Unpretty - -pprReg (FixedReg i) = pprSparcReg i -pprReg (MappedReg i) = pprSparcReg i -pprReg other = uppStr (show other) -- should only happen when debugging - -pprSparcReg :: FAST_INT -> Unpretty -pprSparcReg i = uppPStr - (case i of { - 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( 6) -> SLIT("%g6"); ILIT( 7) -> SLIT("%g7"); - 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(14) -> SLIT("%o6"); ILIT(15) -> SLIT("%o7"); - 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(22) -> SLIT("%l6"); ILIT(23) -> SLIT("%l7"); - 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(30) -> SLIT("%i6"); ILIT(31) -> SLIT("%i7"); - 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(38) -> SLIT("%f6"); ILIT(39) -> SLIT("%f7"); - 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(46) -> SLIT("%f14"); ILIT(47) -> SLIT("%f15"); - 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(54) -> SLIT("%f22"); ILIT(55) -> SLIT("%f23"); - 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(62) -> SLIT("%f30"); ILIT(63) -> SLIT("%f31"); - _ -> SLIT("very naughty sparc register") - }) - -pprCond :: Cond -> Unpretty -pprCond x = uppPStr - (case x of { - ALWAYS -> SLIT(""); NEVER -> SLIT("n"); - GEU -> SLIT("geu"); LU -> SLIT("lu"); - EQ -> SLIT("e"); GT -> SLIT("g"); - GE -> SLIT("ge"); GU -> SLIT("gu"); - LT -> SLIT("l"); LE -> SLIT("le"); - LEU -> SLIT("leu"); NE -> SLIT("ne"); - NEG -> SLIT("neg"); POS -> SLIT("pos"); - VC -> SLIT("vc"); VS -> SLIT("vs") - }) - -pprImm :: PprStyle -> Imm -> Unpretty - -pprImm sty (ImmInt i) = uppInt i -pprImm sty (ImmInteger i) = uppInteger i - -pprImm sty (LO i) = - uppBesides [ - pp_lo, - pprImm sty i, - uppRparen - ] - where -#ifdef USE_FAST_STRINGS - pp_lo = uppPStr (_packCString (A# "%lo("#)) -#else - pp_lo = uppStr "%lo(" -#endif - -pprImm sty (HI i) = - uppBesides [ - pp_hi, - pprImm sty i, - uppRparen - ] - where -#ifdef USE_FAST_STRINGS - pp_hi = uppPStr (_packCString (A# "%hi("#)) -#else - pp_hi = uppStr "%hi(" -#endif - -pprImm sty (ImmCLbl l) = pprCLabel sty l - -pprImm (PprForAsm _ False _) (ImmLab s) = s -pprImm _ (ImmLab s) = uppBeside (uppChar '_') s - -pprImm sty (ImmLit s) = s - -pprAddr :: PprStyle -> Addr -> Unpretty -pprAddr sty (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1 - -pprAddr sty (AddrRegReg r1 r2) = - uppBesides [ - pprReg r1, - uppChar '+', - pprReg r2 - ] - -pprAddr sty (AddrRegImm r1 (ImmInt i)) - | i == 0 = pprReg r1 - | i < -4096 || i > 4095 = large_offset_error i - | i < 0 = - uppBesides [ - pprReg r1, - uppChar '-', - uppInt (-i) - ] - -pprAddr sty (AddrRegImm r1 (ImmInteger i)) - | i == 0 = pprReg r1 - | i < -4096 || i > 4095 = large_offset_error i - | i < 0 = - uppBesides [ - pprReg r1, - uppChar '-', - uppInteger (-i) - ] - -pprAddr sty (AddrRegImm r1 imm) = - uppBesides [ - pprReg r1, - uppChar '+', - pprImm sty imm - ] - -large_offset_error i - = error ("ERROR: SPARC native-code generator cannot handle large offset ("++show i++");\nprobably because of large constant data structures;\nworkaround: use -fvia-C on this module.\n") - -pprRI :: PprStyle -> RI -> Unpretty -pprRI sty (RIReg r) = pprReg r -pprRI sty (RIImm r) = pprImm sty r - -pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Unpretty -pprSizeRegReg name size reg1 reg2 = - uppBesides [ - uppChar '\t', - uppPStr name, - (case size of - F -> uppPStr SLIT("s\t") - DF -> uppPStr SLIT("d\t")), - pprReg reg1, - uppComma, - pprReg reg2 - ] - -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty -pprSizeRegRegReg name size reg1 reg2 reg3 = - uppBesides [ - uppChar '\t', - uppPStr name, - (case size of - F -> uppPStr SLIT("s\t") - DF -> uppPStr SLIT("d\t")), - pprReg reg1, - uppComma, - pprReg reg2, - uppComma, - pprReg reg3 - ] - -pprRegRIReg :: PprStyle -> FAST_STRING -> Bool -> Reg -> RI -> Reg -> Unpretty -pprRegRIReg sty name b reg1 ri reg2 = - uppBesides [ - uppChar '\t', - uppPStr name, - if b then uppPStr SLIT("cc\t") else uppChar '\t', - pprReg reg1, - uppComma, - pprRI sty ri, - uppComma, - pprReg reg2 - ] - -pprRIReg :: PprStyle -> FAST_STRING -> Bool -> RI -> Reg -> Unpretty -pprRIReg sty name b ri reg1 = - uppBesides [ - uppChar '\t', - uppPStr name, - if b then uppPStr SLIT("cc\t") else uppChar '\t', - pprRI sty ri, - uppComma, - pprReg reg1 - ] - -pprSize :: Size -> Unpretty -pprSize x = uppPStr - (case x of - SB -> SLIT("sb") - HW -> SLIT("hw") - UB -> SLIT("ub") - UHW -> SLIT("uhw") - W -> SLIT("") - F -> SLIT("") - D -> SLIT("d") - DF -> SLIT("d") - ) - -#ifdef USE_FAST_STRINGS -pp_ld_lbracket = uppPStr (_packCString (A# "\tld\t["#)) -pp_rbracket_comma = uppPStr (_packCString (A# "],"#)) -pp_comma_lbracket = uppPStr (_packCString (A# ",["#)) -pp_comma_a = uppPStr (_packCString (A# ",a"#)) -#else -pp_ld_lbracket = uppStr "\tld\t[" -pp_rbracket_comma = uppStr "]," -pp_comma_lbracket = uppStr ",[" -pp_comma_a = uppStr ",a" -#endif - -pprSparcInstr :: PprStyle -> SparcInstr -> Unpretty - --- a clumsy hack for now, to handle possible alignment problems - -pprSparcInstr sty (LD DF addr reg) | maybeToBool addrOff = - uppBesides [ - pp_ld_lbracket, - pprAddr sty addr, - pp_rbracket_comma, - pprReg reg, - - uppChar '\n', - pp_ld_lbracket, - pprAddr sty addr2, - pp_rbracket_comma, - pprReg (fPair reg) - ] - where - addrOff = offset addr 4 - addr2 = case addrOff of Just x -> x - -pprSparcInstr sty (LD size addr reg) = - uppBesides [ - uppPStr SLIT("\tld"), - pprSize size, - uppChar '\t', - uppLbrack, - pprAddr sty addr, - pp_rbracket_comma, - pprReg reg - ] - --- The same clumsy hack as above - -pprSparcInstr sty (ST DF reg addr) | maybeToBool addrOff = - uppBesides [ - uppPStr SLIT("\tst\t"), - pprReg reg, - pp_comma_lbracket, - pprAddr sty addr, - - uppPStr SLIT("]\n\tst\t"), - pprReg (fPair reg), - pp_comma_lbracket, - pprAddr sty addr2, - uppRbrack - ] - where - addrOff = offset addr 4 - addr2 = case addrOff of Just x -> x - -pprSparcInstr sty (ST size reg addr) = - uppBesides [ - uppPStr SLIT("\tst"), - pprSize size, - uppChar '\t', - pprReg reg, - pp_comma_lbracket, - pprAddr sty addr, - uppRbrack - ] - -pprSparcInstr sty (ADD x cc reg1 ri reg2) - | not x && not cc && riZero ri = - uppBesides [ - uppPStr SLIT("\tmov\t"), - pprReg reg1, - uppComma, - pprReg reg2 - ] - | otherwise = pprRegRIReg sty (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2 - -pprSparcInstr sty (SUB x cc reg1 ri reg2) - | not x && cc && reg2 == g0 = - uppBesides [ - uppPStr SLIT("\tcmp\t"), - pprReg reg1, - uppComma, - pprRI sty ri - ] - | not x && not cc && riZero ri = - uppBesides [ - uppPStr SLIT("\tmov\t"), - pprReg reg1, - uppComma, - pprReg reg2 - ] - | otherwise = pprRegRIReg sty (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2 - -pprSparcInstr sty (AND b reg1 ri reg2) = pprRegRIReg sty SLIT("and") b reg1 ri reg2 -pprSparcInstr sty (ANDN b reg1 ri reg2) = pprRegRIReg sty SLIT("andn") b reg1 ri reg2 - -pprSparcInstr sty (OR b reg1 ri reg2) - | not b && reg1 == g0 = - uppBesides [ - uppPStr SLIT("\tmov\t"), - pprRI sty ri, - uppComma, - pprReg reg2 - ] - | otherwise = pprRegRIReg sty SLIT("or") b reg1 ri reg2 - -pprSparcInstr sty (ORN b reg1 ri reg2) = pprRegRIReg sty SLIT("orn") b reg1 ri reg2 - -pprSparcInstr sty (XOR b reg1 ri reg2) = pprRegRIReg sty SLIT("xor") b reg1 ri reg2 -pprSparcInstr sty (XNOR b reg1 ri reg2) = pprRegRIReg sty SLIT("xnor") b reg1 ri reg2 - -pprSparcInstr sty (SLL reg1 ri reg2) = pprRegRIReg sty SLIT("sll") False reg1 ri reg2 -pprSparcInstr sty (SRL reg1 ri reg2) = pprRegRIReg sty SLIT("srl") False reg1 ri reg2 -pprSparcInstr sty (SRA reg1 ri reg2) = pprRegRIReg sty SLIT("sra") False reg1 ri reg2 - -pprSparcInstr sty (SETHI imm reg) = - uppBesides [ - uppPStr SLIT("\tsethi\t"), - pprImm sty imm, - uppComma, - pprReg reg - ] - -pprSparcInstr sty (NOP) = uppPStr SLIT("\tnop") - -pprSparcInstr sty (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2 -pprSparcInstr sty (FABS DF reg1 reg2) = - uppBeside (pprSizeRegReg SLIT("fabs") F reg1 reg2) - (if (reg1 == reg2) then uppNil - else uppBeside (uppChar '\n') - (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2))) - -pprSparcInstr sty (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3 -pprSparcInstr sty (FCMP e size reg1 reg2) = - pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2 -pprSparcInstr sty (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3 - -pprSparcInstr sty (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2 -pprSparcInstr sty (FMOV DF reg1 reg2) = - uppBeside (pprSizeRegReg SLIT("fmov") F reg1 reg2) - (if (reg1 == reg2) then uppNil - else uppBeside (uppChar '\n') - (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2))) - -pprSparcInstr sty (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3 - -pprSparcInstr sty (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2 -pprSparcInstr sty (FNEG DF reg1 reg2) = - uppBeside (pprSizeRegReg SLIT("fneg") F reg1 reg2) - (if (reg1 == reg2) then uppNil - else uppBeside (uppChar '\n') - (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2))) - -pprSparcInstr sty (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2 -pprSparcInstr sty (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3 -pprSparcInstr sty (FxTOy size1 size2 reg1 reg2) = - uppBesides [ - uppPStr SLIT("\tf"), - uppPStr - (case size1 of - W -> SLIT("ito") - F -> SLIT("sto") - DF -> SLIT("dto")), - uppPStr - (case size2 of - W -> SLIT("i\t") - F -> SLIT("s\t") - DF -> SLIT("d\t")), - pprReg reg1, - uppComma, - pprReg reg2 - ] - - -pprSparcInstr sty (BI cond b lab) = - uppBesides [ - uppPStr SLIT("\tb"), pprCond cond, - if b then pp_comma_a else uppNil, - uppChar '\t', - pprImm sty lab - ] - -pprSparcInstr sty (BF cond b lab) = - uppBesides [ - uppPStr SLIT("\tfb"), pprCond cond, - if b then pp_comma_a else uppNil, - uppChar '\t', - pprImm sty lab - ] - -pprSparcInstr sty (JMP addr) = uppBeside (uppPStr SLIT("\tjmp\t")) (pprAddr sty addr) - -pprSparcInstr sty (CALL imm n _) = - uppBesides [ - uppPStr SLIT("\tcall\t"), - pprImm sty imm, - uppComma, - uppInt n - ] - -pprSparcInstr sty (LABEL clab) = - uppBesides [ - if (externallyVisibleCLabel clab) then - uppBesides [uppPStr SLIT("\t.global\t"), pprLab, uppChar '\n'] - else - uppNil, - pprLab, - uppChar ':' - ] - where pprLab = pprCLabel sty clab - -pprSparcInstr sty (COMMENT s) = uppBeside (uppPStr SLIT("! ")) (uppPStr s) - -pprSparcInstr sty (SEGMENT TextSegment) - = uppPStr SLIT("\t.text\n\t.align 4") - -pprSparcInstr sty (SEGMENT DataSegment) - = uppPStr SLIT("\t.data\n\t.align 8") -- Less than 8 will break double constants - -pprSparcInstr sty (ASCII False str) = - uppBesides [ - uppStr "\t.asciz \"", - uppStr str, - uppChar '"' - ] - -pprSparcInstr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60) - where - 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 [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\"")) - asciify (c:(cs@(d:_))) n | isDigit d = - uppBeside (uppStr (charToC c)) (asciify cs 0) - | otherwise = - uppBeside (uppStr (charToC c)) (asciify cs (n-1)) - -pprSparcInstr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs) - where pp_item x = case s of - SB -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x) - UB -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x) - W -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x) - DF -> uppBeside (uppPStr SLIT("\t.double\t")) (pprImm sty x) - -\end{code} - -%************************************************************************ -%* * -\subsection[Schedule]{Register allocation information} -%* * -%************************************************************************ - -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 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 -sets: one for single precision and one for double precision. We never seem -to run out of floating point registers anyway. - -\begin{code} - -data SparcRegs = SRegs BitSet BitSet BitSet - -instance MachineRegisters SparcRegs where - mkMRegs xs = SRegs (mkBS ints) (mkBS singles') (mkBS doubles') - where - (ints, floats) = partition (< 32) xs - (singles, doubles) = partition (< 48) floats - singles' = map (subtract 32) singles - doubles' = map (subtract 32) (filter even 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 = - if n _LT_ ILIT(32) then SRegs (ints `minusBS` singletonBS IBOX(n)) singles doubles - else if n _LT_ ILIT(48) then SRegs ints (singles `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) doubles - else SRegs ints singles (doubles `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) - - useMRegs (SRegs ints singles doubles) xs = - SRegs (ints `minusBS` ints') - (singles `minusBS` singles') - (doubles `minusBS` doubles') - where - 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 if n _LT_ ILIT(48) then SRegs ints (singles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) doubles - else SRegs ints singles (doubles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) - - freeMRegs (SRegs ints singles doubles) xs = - SRegs (ints `unionBS` ints') - (singles `unionBS` singles') - (doubles `unionBS` doubles') - where - SRegs ints' singles' doubles' = mkMRegs xs - -instance MachineCode SparcInstr where - regUsage = sparcRegUsage - regLiveness = sparcRegLiveness - patchRegs = sparcPatchRegs - - -- We spill just below the frame pointer, leaving two words per spill location. - spillReg dyn (MemoryReg i pk) = mkUnitList (ST (kindToSize pk) dyn (fpRel (-2 * i))) - loadReg (MemoryReg i pk) dyn = mkUnitList (LD (kindToSize pk) (fpRel (-2 * i)) dyn) - --- Duznae work for offsets greater than 13 bits; we just hope for the best -fpRel :: Int -> Addr -fpRel n = AddrRegImm fp (ImmInt (n * 4)) - -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} - -@sparcRegUsage@ returns the sets of src and destination registers used by -a particular instruction. Machine registers that are pre-allocated -to stgRegs are filtered out, because they are uninteresting from a -register allocation standpoint. (We wouldn't want them to end up on -the free list!) - -\begin{code} - -sparcRegUsage :: SparcInstr -> RegUsage -sparcRegUsage instr = case instr of - LD sz addr reg -> usage (regAddr addr, [reg]) - ST sz reg addr -> usage (reg : regAddr addr, []) - ADD x cc r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB x cc r1 ar r2 -> usage (r1 : regRI ar, [r2]) - AND b r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDN b r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR b r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORN b r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR b r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XNOR b r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SETHI imm reg -> usage ([], [reg]) - FABS s r1 r2 -> usage ([r1], [r2]) - FADD s r1 r2 r3 -> usage ([r1, r2], [r3]) - FCMP e s r1 r2 -> usage ([r1, r2], []) - FDIV s r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV s r1 r2 -> usage ([r1], [r2]) - FMUL s r1 r2 r3 -> usage ([r1, r2], [r3]) - FNEG s r1 r2 -> usage ([r1], [r2]) - FSQRT s r1 r2 -> usage ([r1], [r2]) - FSUB s r1 r2 r3 -> usage ([r1, r2], [r3]) - FxTOy s1 s2 r1 r2 -> usage ([r1], [r2]) - - -- We assume that all local jumps will be BI/BF. JMP must be out-of-line. - JMP addr -> RU (mkUniqSet (filter interesting (regAddr addr))) freeSet - - CALL _ n True -> endUsage - CALL _ n False -> RU (argSet n) callClobberedSet - - _ -> noUsage - - where - usage (src, dst) = RU (mkUniqSet (filter interesting src)) - (mkUniqSet (filter interesting dst)) - - interesting (FixedReg _) = False - interesting _ = True - - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] - - regRI (RIReg r) = [r] - regRI _ = [] - -freeRegs :: [Reg] -freeRegs = freeMappedRegs (\ x -> x) [0..63] - -freeMappedRegs :: (Int -> Int) -> [Int] -> [Reg] - -freeMappedRegs modify nums - = foldr free [] nums - where - free n acc - = let - modified_i = case (modify n) of { IBOX(x) -> x } - in - if _IS_TRUE_(freeReg modified_i) then (MappedReg modified_i) : acc else acc - -freeSet :: UniqSet Reg -freeSet = mkUniqSet freeRegs - -noUsage :: RegUsage -noUsage = RU emptyUniqSet emptyUniqSet - -endUsage :: RegUsage -endUsage = RU emptyUniqSet freeSet - --- Color me CAF-like -argSet :: Int -> UniqSet Reg -argSet 0 = emptyUniqSet -argSet 1 = mkUniqSet (freeMappedRegs oReg [0]) -argSet 2 = mkUniqSet (freeMappedRegs oReg [0,1]) -argSet 3 = mkUniqSet (freeMappedRegs oReg [0,1,2]) -argSet 4 = mkUniqSet (freeMappedRegs oReg [0,1,2,3]) -argSet 5 = mkUniqSet (freeMappedRegs oReg [0,1,2,3,4]) -argSet 6 = mkUniqSet (freeMappedRegs oReg [0,1,2,3,4,5]) - -callClobberedSet :: UniqSet Reg -callClobberedSet = mkUniqSet callClobberedRegs - where - callClobberedRegs = freeMappedRegs (\x -> x) - ( oReg 7 : - [oReg i | i <- [0..5]] ++ - [gReg i | i <- [1..7]] ++ - [fReg i | i <- [0..31]] ) - -\end{code} - -@sparcRegLiveness@ takes future liveness information and modifies it according to -the semantics of branches and labels. (An out-of-line branch clobbers the liveness -passed back by the following instruction; a forward local branch passes back the -liveness from the target label; a conditional branch merges the liveness from the -target and the liveness from its successor; a label stashes away the current liveness -in the future liveness environment). - -\begin{code} -sparcRegLiveness :: SparcInstr -> RegLiveness -> RegLiveness -sparcRegLiveness instr info@(RL live future@(FL all env)) = case instr of - - -- We assume that all local jumps will be BI/BF. JMP must be out-of-line. - - BI ALWAYS _ (ImmCLbl lbl) -> RL (lookup lbl) future - BI _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionUniqSets` live) future - BF ALWAYS _ (ImmCLbl lbl) -> RL (lookup lbl) future - BF _ _ (ImmCLbl lbl) -> RL (lookup lbl `unionUniqSets` live) future - JMP _ -> RL emptyUniqSet future - CALL _ i True -> RL emptyUniqSet future - CALL _ i False -> RL live future - LABEL lbl -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live)) - _ -> info - - where - lookup lbl = case lookupFM env lbl of - Just regs -> regs - Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++ - " in future?") emptyUniqSet - -\end{code} - -@sparcPatchRegs@ takes an instruction (possibly with MemoryReg/UnmappedReg registers) and -changes all register references according to the supplied environment. - -\begin{code} - -sparcPatchRegs :: SparcInstr -> (Reg -> Reg) -> SparcInstr -sparcPatchRegs instr env = case instr of - LD sz addr reg -> LD sz (fixAddr addr) (env reg) - ST sz reg addr -> ST sz (env reg) (fixAddr addr) - ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) - SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) - AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) - ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) - OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) - ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) - XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) - XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - SETHI imm reg -> SETHI imm (env reg) - FABS s r1 r2 -> FABS s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMOV s r1 r2 -> FMOV s (env r1) (env r2) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) - JMP addr -> JMP (fixAddr addr) - _ -> instr - - where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other -\end{code} - -Sometimes, we want to be able to modify addresses at compile time. -(Okay, just for chrCode of a fetch.) - -\begin{code} -{-# SPECIALIZE - is13Bits :: Int -> Bool - #-} -{-# SPECIALIZE - is13Bits :: Integer -> Bool - #-} - -is13Bits :: Integral a => a -> Bool -is13Bits x = x >= -4096 && x < 4096 - -offset :: Addr -> Int -> Maybe Addr - -offset (AddrRegImm reg (ImmInt n)) off - | is13Bits n2 = Just (AddrRegImm reg (ImmInt n2)) - | otherwise = Nothing - where n2 = n + off - -offset (AddrRegImm reg (ImmInteger n)) off - | is13Bits n2 = Just (AddrRegImm reg (ImmInt (fromInteger n2))) - | otherwise = Nothing - where n2 = n + toInteger off - -offset (AddrRegReg reg (FixedReg ILIT(0))) off - | is13Bits off = Just (AddrRegImm reg (ImmInt off)) - | otherwise = Nothing - -offset _ _ = Nothing - -\end{code} - -If you value your sanity, do not venture below this line. - -\begin{code} - --- platform.h is generate and tells us what the target architecture is -#include "../../includes/platform.h" -#include "../../includes/MachRegs.h" -#if sunos4_TARGET_OS -#include "../../includes/sparc-sun-sunos4.h" -#else -#include "../../includes/sparc-sun-solaris2.h" -#endif - --- Redefine the literals used for Sparc register names in the header --- files. Gag me with a spoon, eh? - -#define g0 0 -#define g1 1 -#define g2 2 -#define g3 3 -#define g4 4 -#define g5 5 -#define g6 6 -#define g7 7 -#define o0 8 -#define o1 9 -#define o2 10 -#define o3 11 -#define o4 12 -#define o5 13 -#define o6 14 -#define o7 15 -#define l0 16 -#define l1 17 -#define l2 18 -#define l3 19 -#define l4 20 -#define l5 21 -#define l6 22 -#define l7 23 -#define i0 24 -#define i1 25 -#define i2 26 -#define i3 27 -#define i4 28 -#define i5 29 -#define i6 30 -#define i7 31 -#define f0 32 -#define f1 33 -#define f2 34 -#define f3 35 -#define f4 36 -#define f5 37 -#define f6 38 -#define f7 39 -#define f8 40 -#define f9 41 -#define f10 42 -#define f11 43 -#define f12 44 -#define f13 45 -#define f14 46 -#define f15 47 -#define f16 48 -#define f17 49 -#define f18 50 -#define f19 51 -#define f20 52 -#define f21 53 -#define f22 54 -#define f23 55 -#define f24 56 -#define f25 57 -#define f26 58 -#define f27 59 -#define f28 60 -#define f29 61 -#define f30 62 -#define f31 63 - -baseRegOffset :: MagicId -> Int -baseRegOffset StkOReg = OFFSET_StkO -baseRegOffset (VanillaReg _ ILIT2(1)) = OFFSET_R1 -baseRegOffset (VanillaReg _ ILIT2(2)) = OFFSET_R2 -baseRegOffset (VanillaReg _ ILIT2(3)) = OFFSET_R3 -baseRegOffset (VanillaReg _ ILIT2(4)) = OFFSET_R4 -baseRegOffset (VanillaReg _ ILIT2(5)) = OFFSET_R5 -baseRegOffset (VanillaReg _ ILIT2(6)) = OFFSET_R6 -baseRegOffset (VanillaReg _ ILIT2(7)) = OFFSET_R7 -baseRegOffset (VanillaReg _ ILIT2(8)) = OFFSET_R8 -baseRegOffset (FloatReg ILIT2(1)) = OFFSET_Flt1 -baseRegOffset (FloatReg ILIT2(2)) = OFFSET_Flt2 -baseRegOffset (FloatReg ILIT2(3)) = OFFSET_Flt3 -baseRegOffset (FloatReg ILIT2(4)) = OFFSET_Flt4 -baseRegOffset (DoubleReg ILIT2(1)) = OFFSET_Dbl1 -baseRegOffset (DoubleReg ILIT2(2)) = OFFSET_Dbl2 -baseRegOffset TagReg = OFFSET_Tag -baseRegOffset RetReg = OFFSET_Ret -baseRegOffset SpA = OFFSET_SpA -baseRegOffset SuA = OFFSET_SuA -baseRegOffset SpB = OFFSET_SpB -baseRegOffset SuB = OFFSET_SuB -baseRegOffset Hp = OFFSET_Hp -baseRegOffset HpLim = OFFSET_HpLim -baseRegOffset LivenessReg = OFFSET_Liveness ---baseRegOffset ActivityReg = OFFSET_Activity -#ifdef DEBUG -baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" -baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg" -baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg" -baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre" -baseRegOffset VoidReg = panic "baseRegOffset:VoidReg" -#endif - -callerSaves :: MagicId -> Bool -#ifdef CALLER_SAVES_Base -callerSaves BaseReg = True -#endif -#ifdef CALLER_SAVES_StkO -callerSaves StkOReg = True -#endif -#ifdef CALLER_SAVES_R1 -callerSaves (VanillaReg _ ILIT2(1)) = True -#endif -#ifdef CALLER_SAVES_R2 -callerSaves (VanillaReg _ ILIT2(2)) = True -#endif -#ifdef CALLER_SAVES_R3 -callerSaves (VanillaReg _ ILIT2(3)) = True -#endif -#ifdef CALLER_SAVES_R4 -callerSaves (VanillaReg _ ILIT2(4)) = True -#endif -#ifdef CALLER_SAVES_R5 -callerSaves (VanillaReg _ ILIT2(5)) = True -#endif -#ifdef CALLER_SAVES_R6 -callerSaves (VanillaReg _ ILIT2(6)) = True -#endif -#ifdef CALLER_SAVES_R7 -callerSaves (VanillaReg _ ILIT2(7)) = True -#endif -#ifdef CALLER_SAVES_R8 -callerSaves (VanillaReg _ ILIT2(8)) = True -#endif -#ifdef CALLER_SAVES_FltReg1 -callerSaves (FloatReg ILIT2(1)) = True -#endif -#ifdef CALLER_SAVES_FltReg2 -callerSaves (FloatReg ILIT2(2)) = True -#endif -#ifdef CALLER_SAVES_FltReg3 -callerSaves (FloatReg ILIT2(3)) = True -#endif -#ifdef CALLER_SAVES_FltReg4 -callerSaves (FloatReg ILIT2(4)) = True -#endif -#ifdef CALLER_SAVES_DblReg1 -callerSaves (DoubleReg ILIT2(1)) = True -#endif -#ifdef CALLER_SAVES_DblReg2 -callerSaves (DoubleReg ILIT2(2)) = True -#endif -#ifdef CALLER_SAVES_Tag -callerSaves TagReg = True -#endif -#ifdef CALLER_SAVES_Ret -callerSaves RetReg = True -#endif -#ifdef CALLER_SAVES_SpA -callerSaves SpA = True -#endif -#ifdef CALLER_SAVES_SuA -callerSaves SuA = True -#endif -#ifdef CALLER_SAVES_SpB -callerSaves SpB = True -#endif -#ifdef CALLER_SAVES_SuB -callerSaves SuB = True -#endif -#ifdef CALLER_SAVES_Hp -callerSaves Hp = True -#endif -#ifdef CALLER_SAVES_HpLim -callerSaves HpLim = True -#endif -#ifdef CALLER_SAVES_Liveness -callerSaves LivenessReg = True -#endif -#ifdef CALLER_SAVES_Activity ---callerSaves ActivityReg = True -#endif -#ifdef CALLER_SAVES_StdUpdRetVec -callerSaves StdUpdRetVecReg = True -#endif -#ifdef CALLER_SAVES_StkStub -callerSaves StkStubReg = True -#endif -callerSaves _ = False - -stgRegMap :: MagicId -> Maybe Reg -#ifdef REG_Base -stgRegMap BaseReg = Just (FixedReg ILIT(REG_Base)) -#endif -#ifdef REG_StkO -stgRegMap StkOReg = Just (FixedReg ILIT(REG_StkOReg)) -#endif -#ifdef REG_R1 -stgRegMap (VanillaReg _ ILIT2(1)) = Just (FixedReg ILIT(REG_R1)) -#endif -#ifdef REG_R2 -stgRegMap (VanillaReg _ ILIT2(2)) = Just (FixedReg ILIT(REG_R2)) -#endif -#ifdef REG_R3 -stgRegMap (VanillaReg _ ILIT2(3)) = Just (FixedReg ILIT(REG_R3)) -#endif -#ifdef REG_R4 -stgRegMap (VanillaReg _ ILIT2(4)) = Just (FixedReg ILIT(REG_R4)) -#endif -#ifdef REG_R5 -stgRegMap (VanillaReg _ ILIT2(5)) = Just (FixedReg ILIT(REG_R5)) -#endif -#ifdef REG_R6 -stgRegMap (VanillaReg _ ILIT2(6)) = Just (FixedReg ILIT(REG_R6)) -#endif -#ifdef REG_R7 -stgRegMap (VanillaReg _ ILIT2(7)) = Just (FixedReg ILIT(REG_R7)) -#endif -#ifdef REG_R8 -stgRegMap (VanillaReg _ ILIT2(8)) = Just (FixedReg ILIT(REG_R8)) -#endif -#ifdef REG_Flt1 -stgRegMap (FloatReg ILIT2(1)) = Just (FixedReg ILIT(REG_Flt1)) -#endif -#ifdef REG_Flt2 -stgRegMap (FloatReg ILIT2(2)) = Just (FixedReg ILIT(REG_Flt2)) -#endif -#ifdef REG_Flt3 -stgRegMap (FloatReg ILIT2(3)) = Just (FixedReg ILIT(REG_Flt3)) -#endif -#ifdef REG_Flt4 -stgRegMap (FloatReg ILIT2(4)) = Just (FixedReg ILIT(REG_Flt4)) -#endif -#ifdef REG_Dbl1 -stgRegMap (DoubleReg ILIT2(1)) = Just (FixedReg ILIT(REG_Dbl1)) -#endif -#ifdef REG_Dbl2 -stgRegMap (DoubleReg ILIT2(2)) = Just (FixedReg ILIT(REG_Dbl2)) -#endif -#ifdef REG_Tag -stgRegMap TagReg = Just (FixedReg ILIT(REG_TagReg)) -#endif -#ifdef REG_Ret -stgRegMap RetReg = Just (FixedReg ILIT(REG_Ret)) -#endif -#ifdef REG_SpA -stgRegMap SpA = Just (FixedReg ILIT(REG_SpA)) -#endif -#ifdef REG_SuA -stgRegMap SuA = Just (FixedReg ILIT(REG_SuA)) -#endif -#ifdef REG_SpB -stgRegMap SpB = Just (FixedReg ILIT(REG_SpB)) -#endif -#ifdef REG_SuB -stgRegMap SuB = Just (FixedReg ILIT(REG_SuB)) -#endif -#ifdef REG_Hp -stgRegMap Hp = Just (FixedReg ILIT(REG_Hp)) -#endif -#ifdef REG_HpLim -stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim)) -#endif -#ifdef REG_Liveness -stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness)) -#endif -#ifdef REG_Activity ---stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity)) -#endif -#ifdef REG_StdUpdRetVec -stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec)) -#endif -#ifdef REG_StkStub -stgRegMap StkStubReg = Just (FixedReg ILIT(REG_StkStub)) -#endif -stgRegMap _ = Nothing - -\end{code} - -Here is the list of registers we can use in register allocation. - -\begin{code} - -freeReg :: FAST_INT -> FAST_BOOL - -freeReg ILIT(g0) = _FALSE_ -- %g0 is always 0. -freeReg ILIT(g5) = _FALSE_ -- %g5 is reserved (ABI). -freeReg ILIT(g6) = _FALSE_ -- %g6 is reserved (ABI). -freeReg ILIT(g7) = _FALSE_ -- %g7 is reserved (ABI). -freeReg ILIT(i6) = _FALSE_ -- %i6 is our frame pointer. -freeReg ILIT(o6) = _FALSE_ -- %o6 is our stack pointer. - -#ifdef REG_Base -freeReg ILIT(REG_Base) = _FALSE_ -#endif -#ifdef REG_StkO -freeReg ILIT(REG_StkO) = _FALSE_ -#endif -#ifdef REG_R1 -freeReg ILIT(REG_R1) = _FALSE_ -#endif -#ifdef REG_R2 -freeReg ILIT(REG_R2) = _FALSE_ -#endif -#ifdef REG_R3 -freeReg ILIT(REG_R3) = _FALSE_ -#endif -#ifdef REG_R4 -freeReg ILIT(REG_R4) = _FALSE_ -#endif -#ifdef REG_R5 -freeReg ILIT(REG_R5) = _FALSE_ -#endif -#ifdef REG_R6 -freeReg ILIT(REG_R6) = _FALSE_ -#endif -#ifdef REG_R7 -freeReg ILIT(REG_R7) = _FALSE_ -#endif -#ifdef REG_R8 -freeReg ILIT(REG_R8) = _FALSE_ -#endif -#ifdef REG_Flt1 -freeReg ILIT(REG_Flt1) = _FALSE_ -#endif -#ifdef REG_Flt2 -freeReg ILIT(REG_Flt2) = _FALSE_ -#endif -#ifdef REG_Flt3 -freeReg ILIT(REG_Flt3) = _FALSE_ -#endif -#ifdef REG_Flt4 -freeReg ILIT(REG_Flt4) = _FALSE_ -#endif -#ifdef REG_Dbl1 -freeReg ILIT(REG_Dbl1) = _FALSE_ -#endif -#ifdef REG_Dbl2 -freeReg ILIT(REG_Dbl2) = _FALSE_ -#endif -#ifdef REG_Tag -freeReg ILIT(REG_Tag) = _FALSE_ -#endif -#ifdef REG_Ret -freeReg ILIT(REG_Ret) = _FALSE_ -#endif -#ifdef REG_SpA -freeReg ILIT(REG_SpA) = _FALSE_ -#endif -#ifdef REG_SuA -freeReg ILIT(REG_SuA) = _FALSE_ -#endif -#ifdef REG_SpB -freeReg ILIT(REG_SpB) = _FALSE_ -#endif -#ifdef REG_SuB -freeReg ILIT(REG_SuB) = _FALSE_ -#endif -#ifdef REG_Hp -freeReg ILIT(REG_Hp) = _FALSE_ -#endif -#ifdef REG_HpLim -freeReg ILIT(REG_HpLim) = _FALSE_ -#endif -#ifdef REG_Liveness -freeReg ILIT(REG_Liveness) = _FALSE_ -#endif -#ifdef REG_Activity ---freeReg ILIT(REG_Activity) = _FALSE_ -#endif -#ifdef REG_StdUpdRetVec -freeReg ILIT(REG_StdUpdRetVec) = _FALSE_ -#endif -#ifdef REG_StkStub -freeReg ILIT(REG_StkStub) = _FALSE_ -#endif -freeReg n -#ifdef REG_Dbl1 - | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_ -#endif -#ifdef REG_Dbl2 - | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_ -#endif - | otherwise = _TRUE_ - -reservedRegs :: [Int] -reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2, - NCG_Reserved_F1, NCG_Reserved_F2, - NCG_Reserved_D1, NCG_Reserved_D2] - -\end{code} - diff --git a/ghc/compiler/nativeGen/SparcDesc.lhs b/ghc/compiler/nativeGen/SparcDesc.lhs deleted file mode 100644 index 8445399..0000000 --- a/ghc/compiler/nativeGen/SparcDesc.lhs +++ /dev/null @@ -1,197 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1995 -% -\section[SparcDesc]{The Sparc Machine Description} - -\begin{code} -#include "HsVersions.h" - -module SparcDesc ( - mkSparc - - -- and assorted nonsense referenced by the class methods - ) where - -import AbsCSyn -import PrelInfo ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..), - RegLiveness(..), RegUsage(..), FutureLive(..) - ) -import CLabel ( CLabel ) -import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) ) -import HeapOffs ( hpRelToInt ) -import MachDesc -import Maybes ( Maybe(..) ) -import OrdList -import Outputable -import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) -import SparcCode -import SparcGen ( sparcCodeGen ) -import Stix -import StixMacro -import StixPrim -import UniqSupply -import Util -\end{code} - -Header sizes depend only on command-line options, not on the target -architecture. (I think.) - -\begin{code} - -fhs :: (GlobalSwitch -> SwitchResult) -> Int - -fhs switches = 1 + profFHS + ageFHS - where - profFHS = if switchIsOn switches SccProfilingOn then 1 else 0 - ageFHS = if switchIsOn switches SccProfilingOn then 1 else 0 - -vhs :: (GlobalSwitch -> SwitchResult) -> SMRep -> Int - -vhs switches sm = case sm of - StaticRep _ _ -> 0 - SpecialisedRep _ _ _ _ -> 0 - GenericRep _ _ _ -> 0 - BigTupleRep _ -> 1 - MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -} - DataRep _ -> 1 - DynamicRep -> 2 - BlackHoleRep -> 0 - PhantomRep -> panic "vhs:phantom" - -\end{code} - -Here we map STG registers onto appropriate Stix Trees. First, we -handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@. -The rest are either in real machine registers or stored as offsets -from BaseReg. - -\begin{code} - -sparcReg :: (GlobalSwitch -> SwitchResult) -> MagicId -> RegLoc - -sparcReg switches x = - case stgRegMap x of - Just reg -> Save nonReg - Nothing -> Always nonReg - where nonReg = case x of - StkStubReg -> sStLitLbl SLIT("STK_STUB_closure") - StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame") - BaseReg -> sStLitLbl SLIT("MainRegTable") - 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) - _ -> StInd (kindFromMagicId x) - (StPrim IntAddOp [baseLoc, StInt (toInteger (offset*4))]) - baseLoc = case stgRegMap BaseReg of - Just _ -> StReg (StixMagicId BaseReg) - Nothing -> sStLitLbl SLIT("MainRegTable") - offset = baseRegOffset x - -\end{code} - -Sizes in bytes. - -\begin{code} - -size pk = case kindToSize pk of - {SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 8} - -\end{code} - -Now the volatile saves and restores. We add the basic guys to the list of ``user'' -registers provided. Note that there are more basic registers on the restore list, -because some are reloaded from constants. - -\begin{code} - -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 - 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) - ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols)) - where - restore x = StAssign (kindFromMagicId x) reg loc - where reg = StReg (StixMagicId x) - loc = case sparcReg switches x of - Save loc -> loc - Always loc -> panic "vrests" - -\end{code} - -Static closure sizes. - -\begin{code} - -charLikeSize, intLikeSize :: Target -> Int - -charLikeSize target = - size PtrRep * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1) - where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm - -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 - words = fhs switches + vhs switches (MuTupleRep 0) - -dhs switches = StInt (toInteger words) - where - words = fhs switches + vhs switches (DataRep 0) - -\end{code} - -Setting up a sparc target. - -\begin{code} - -mkSparc :: Bool - -> (GlobalSwitch -> SwitchResult) - -> (Target, - (PprStyle -> [[StixTree]] -> UniqSM Unpretty), -- codeGen - Bool, -- underscore - (String -> String)) -- fmtAsmLbl - -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 - csz = charLikeSize target - isz = intLikeSize target - mhs' = mhs switches - dhs' = dhs switches - ps = genPrimCode target - mc = genMacroCode target - hc = doHeapCheck - target = mkTarget {-switches-} fhs' vhs' sparcReg' {-id-} size - hprel as as' - (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc) - {-sparcCodeGen decentOS id-} - in - (target, sparcCodeGen, decentOS, id) -\end{code} diff --git a/ghc/compiler/nativeGen/SparcGen.lhs b/ghc/compiler/nativeGen/SparcGen.lhs deleted file mode 100644 index f5046d7..0000000 --- a/ghc/compiler/nativeGen/SparcGen.lhs +++ /dev/null @@ -1,1289 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1993-1995 -% - -\begin{code} -#include "HsVersions.h" - -module SparcGen ( - sparcCodeGen, - - -- and, for self-sufficiency - PprStyle, StixTree, CSeq - ) where - -IMPORT_Trace - -import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId ) -import PrelInfo ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos, - Reg(..), RegLiveness(..), RegUsage(..), - FutureLive(..), MachineRegisters(..), MachineCode(..) - ) -import CLabel ( CLabel, isAsmTemp ) -import SparcCode {- everything -} -import MachDesc -import Maybes ( maybeToBool, Maybe(..) ) -import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList ) -import Outputable -import SparcDesc -import Stix -import UniqSupply -import Pretty -import Unpretty -import Util - -type CodeBlock a = (OrdList a -> OrdList a) -\end{code} - -%************************************************************************ -%* * -\subsection[SparcCodeGen]{Generating Sparc Code} -%* * -%************************************************************************ - -This is the top-level code-generation function for the Sparc. - -\begin{code} - -sparcCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty -sparcCodeGen sty trees = - mapUs genSparcCode trees `thenUs` \ dynamicCodes -> - let - staticCodes = scheduleSparcCode dynamicCodes - pretty = printLabeledCodes sty staticCodes - in - returnUs pretty - -\end{code} - -This bit does the code scheduling. The scheduler must also deal with -register allocation of temporaries. Much parallelism can be exposed via -the OrdList, but more might occur, so further analysis might be needed. - -\begin{code} - -scheduleSparcCode :: [SparcCode] -> [SparcInstr] -scheduleSparcCode = concat . map (runRegAllocate freeSparcRegs reservedRegs) - where - freeSparcRegs :: SparcRegs - freeSparcRegs = mkMRegs (extractMappedRegNos freeRegs) - - -\end{code} - -Registers passed up the tree. If the stix code forces the register -to live in a pre-decided machine register, it comes out as @Fixed@; -otherwise, it comes out as @Any@, and the parent can decide which -register to put it in. - -\begin{code} - -data Register - = Fixed Reg PrimRep (CodeBlock SparcInstr) - | Any PrimRep (Reg -> (CodeBlock SparcInstr)) - -registerCode :: Register -> Reg -> CodeBlock SparcInstr -registerCode (Fixed _ _ code) reg = code -registerCode (Any _ code) reg = code reg - -registerName :: Register -> Reg -> Reg -registerName (Fixed reg _ _) _ = reg -registerName (Any _ _) reg = reg - -registerKind :: Register -> PrimRep -registerKind (Fixed _ pk _) = pk -registerKind (Any pk _) = pk - -isFixed :: Register -> Bool -isFixed (Fixed _ _ _) = True -isFixed (Any _ _) = False - -\end{code} - -Memory addressing modes passed up the tree. - -\begin{code} - -data Amode = Amode Addr (CodeBlock SparcInstr) - -amodeAddr (Amode addr _) = addr -amodeCode (Amode _ code) = code - -\end{code} - -Condition codes passed up the tree. - -\begin{code} - -data Condition = Condition Bool Cond (CodeBlock SparcInstr) - -condName (Condition _ cond _) = cond -condFloat (Condition float _ _) = float -condCode (Condition _ _ code) = code - -\end{code} - -General things for putting together code sequences. - -\begin{code} - -asmVoid :: OrdList SparcInstr -asmVoid = mkEmptyList - -asmInstr :: SparcInstr -> SparcCode -asmInstr i = mkUnitList i - -asmSeq :: [SparcInstr] -> SparcCode -asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is - -asmParThen :: [SparcCode] -> (CodeBlock SparcInstr) -asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code - -returnInstr :: SparcInstr -> UniqSM (CodeBlock SparcInstr) -returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs) - -returnInstrs :: [SparcInstr] -> UniqSM (CodeBlock SparcInstr) -returnInstrs instrs = returnUs (\xs -> 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 - -mkSeqInstrs :: [SparcInstr] -> (CodeBlock SparcInstr) -mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code - -\end{code} - -Top level sparc code generator for a chunk of stix code. - -\begin{code} - -genSparcCode :: [StixTree] -> UniqSM (SparcCode) - -genSparcCode trees = - mapUs getCode trees `thenUs` \ blocks -> - returnUs (foldr (.) id blocks asmVoid) - -\end{code} - -Code extractor for an entire stix tree---stix statement level. - -\begin{code} - -getCode - :: StixTree -- a stix statement - -> UniqSM (CodeBlock SparcInstr) - -getCode (StSegment seg) = returnInstr (SEGMENT seg) - -getCode (StAssign 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) = returnUs id - -getCode (StJump arg) = genJump arg - -getCode (StFallThrough lbl) = returnUs id - -getCode (StCondJump lbl arg) = genCondJump lbl arg - -getCode (StData kind args) = - mapAndUnzipUs getData args `thenUs` \ (codes, imms) -> - returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms)) - (foldr1 (.) codes xs)) - where - 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) - -\end{code} - -Generate code to get a subtree into a register. - -\begin{code} - -getReg :: StixTree -> UniqSM Register - -getReg (StReg (StixMagicId stgreg)) = - case stgRegMap stgreg of - Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id) - -- cannae be Nothing - -getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id) - -getReg (StDouble d) = - getUniqLabelNCG `thenUs` \ lbl -> - getNewRegNCG PtrRep `thenUs` \ tmp -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - DATA DF [strImmLit ('0' : 'r' : ppShow 80 (ppRational d))], - SEGMENT TextSegment, - SETHI (HI (ImmCLbl lbl)) tmp, - LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - in - returnUs (Any DoubleRep code) - -getReg (StString s) = - getUniqLabelNCG `thenUs` \ lbl -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - ASCII True (_UNPK_ s), - SEGMENT TextSegment, - SETHI (HI (ImmCLbl lbl)) dst, - OR False dst (RIImm (LO (ImmCLbl lbl))) dst] - in - returnUs (Any PtrRep code) - -getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' = - getUniqLabelNCG `thenUs` \ lbl -> - let code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - ASCII False (init xs), - SEGMENT TextSegment, - SETHI (HI (ImmCLbl lbl)) dst, - OR False dst (RIImm (LO (ImmCLbl lbl))) dst] - in - returnUs (Any PtrRep code) - where - xs = _UNPK_ (_TAIL_ s) - -getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree) - -getReg (StCall fn kind args) = - genCCall fn kind args `thenUs` \ call -> - returnUs (Fixed reg kind call) - where - reg = if isFloatingRep kind then f0 else o0 - -getReg (StPrim primop args) = - case primop of - - CharGtOp -> condIntReg GT args - CharGeOp -> condIntReg GE args - CharEqOp -> condIntReg EQ args - CharNeOp -> condIntReg NE args - CharLtOp -> condIntReg LT args - CharLeOp -> condIntReg LE args - - IntAddOp -> trivialCode (ADD False False) args - - IntSubOp -> trivialCode (SUB False False) args - 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 - SllOp -> trivialCode SLL args - SraOp -> trivialCode SRA args - SrlOp -> trivialCode SRL 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 - WordNeOp -> condIntReg NE args - WordLtOp -> condIntReg LU args - WordLeOp -> condIntReg LEU args - - AddrGtOp -> condIntReg GU args - AddrGeOp -> condIntReg GEU args - AddrEqOp -> condIntReg EQ args - AddrNeOp -> condIntReg NE args - AddrLtOp -> condIntReg LU args - AddrLeOp -> condIntReg LEU 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 - FloatEqOp -> condFltReg EQ args - FloatNeOp -> condFltReg NE args - FloatLtOp -> condFltReg LT args - FloatLeOp -> condFltReg LE 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 - DoubleNeOp -> condFltReg NE args - DoubleLtOp -> condFltReg LT args - DoubleLeOp -> condFltReg LE 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 FloatRep args - Double2IntOp -> coerceFP2Int 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] - -getReg (StInd pk mem) = - getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - size = kindToSize pk - code__2 dst = code . mkSeqInstr (LD size src dst) - in - returnUs (Any pk code__2) - -getReg (StInt i) - | is13Bits i = - let - src = ImmInt (fromInteger i) - code dst = mkSeqInstr (OR False g0 (RIImm src) dst) - in - returnUs (Any IntRep code) - -getReg leaf - | maybeToBool imm = - let - code dst = mkSeqInstrs [ - SETHI (HI imm__2) dst, - OR False dst (RIImm (LO imm__2)) dst] - in - returnUs (Any PtrRep code) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - -\end{code} - -Now, given a tree (the argument to an StInd) that references memory, -produce a suitable addressing mode. - -\begin{code} - -getAmode :: StixTree -> UniqSM Amode - -getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) - -getAmode (StPrim IntSubOp [x, StInt i]) - | is13Bits (-i) = - getNewRegNCG PtrRep `thenUs` \ tmp -> - getReg x `thenUs` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (-(fromInteger i)) - in - returnUs (Amode (AddrRegImm reg off) code) - - -getAmode (StPrim IntAddOp [x, StInt i]) - | is13Bits i = - getNewRegNCG PtrRep `thenUs` \ tmp -> - getReg x `thenUs` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (fromInteger i) - in - returnUs (Amode (AddrRegImm reg off) code) - -getAmode (StPrim IntAddOp [x, y]) = - 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 - code2 = registerCode register2 tmp2 asmVoid - reg2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] - in - returnUs (Amode (AddrRegReg reg1 reg2) code__2) - -getAmode leaf - | maybeToBool imm = - getNewRegNCG PtrRep `thenUs` \ tmp -> - let - code = mkSeqInstr (SETHI (HI imm__2) tmp) - in - returnUs (Amode (AddrRegImm tmp (LO imm__2)) code) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - -getAmode other = - getNewRegNCG PtrRep `thenUs` \ tmp -> - getReg other `thenUs` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt 0 - in - returnUs (Amode (AddrRegImm reg off) code) - -\end{code} - -Try to get a value into a specific register (or registers) for a call. The Sparc -calling convention is an absolute nightmare. The first 6x32 bits of arguments are -mapped into %o0 through %o5, and the remaining arguments are dumped to the stack, -beginning at [%sp+92]. (Note that %o6 == %sp.) Our first argument is a pair of -the list of remaining argument registers to be assigned for this call and the next -stack offset to use for overflowing arguments. This way, @getCallArg@ can be applied -to all of a call's arguments using @mapAccumL@. - -\begin{code} - -getCallArg - :: ([Reg],Int) -- Argument registers and stack offset (accumulator) - -> StixTree -- Current argument - -> 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 `thenUs` \ register -> - getNewRegNCG (registerKind register) - `thenUs` \ tmp -> - let - reg = if isFloatingRep pk then tmp else dst - code = registerCode register reg - src = registerName register reg - pk = registerKind register - in - returnUs (case pk of - DoubleRep -> - case dsts of - [] -> (([], offset + 1), code . mkSeqInstrs [ - -- conveniently put the second part in the right stack - -- location, and load the first part into %o5 - 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, - LD W (spRel (-1)) dst__2]) - FloatRep -> ((dsts, offset), code . mkSeqInstrs [ - ST F src (spRel (-2)), - LD W (spRel (-2)) dst]) - _ -> ((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 `thenUs` \ register -> - getNewRegNCG (registerKind register) - `thenUs` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - pk = registerKind register - sz = kindToSize pk - words = if pk == DoubleRep then 2 else 1 - in - returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset))) - -\end{code} - -Set up a condition code for a conditional branch. - -\begin{code} - -getCondition :: StixTree -> UniqSM Condition - -getCondition (StPrim primop args) = - case primop of - - CharGtOp -> condIntCode GT args - CharGeOp -> condIntCode GE args - CharEqOp -> condIntCode EQ args - CharNeOp -> condIntCode NE args - CharLtOp -> condIntCode LT args - CharLeOp -> condIntCode LE args - - IntGtOp -> condIntCode GT args - IntGeOp -> condIntCode GE args - IntEqOp -> condIntCode EQ 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 - WordNeOp -> condIntCode NE args - WordLtOp -> condIntCode LU args - WordLeOp -> condIntCode LEU args - - AddrGtOp -> condIntCode GU args - AddrGeOp -> condIntCode GEU args - AddrEqOp -> condIntCode EQ args - AddrNeOp -> condIntCode NE args - AddrLtOp -> condIntCode LU args - AddrLeOp -> condIntCode LEU args - - FloatGtOp -> condFltCode GT args - FloatGeOp -> condFltCode GE args - FloatEqOp -> condFltCode EQ args - FloatNeOp -> condFltCode NE args - FloatLtOp -> condFltCode LT args - FloatLeOp -> condFltCode LE args - - DoubleGtOp -> condFltCode GT args - DoubleGeOp -> condFltCode GE args - DoubleEqOp -> condFltCode EQ args - DoubleNeOp -> condFltCode NE args - DoubleLtOp -> condFltCode LT args - DoubleLeOp -> condFltCode LE args - -\end{code} - -Turn a boolean expression into a condition, to be passed -back up the tree. - -\begin{code} - -condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition - -condIntCode cond [x, StInt y] - | is13Bits y = - getReg x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> - let - code = registerCode register tmp - src1 = registerName register tmp - src2 = ImmInt (fromInteger y) - code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0) - in - returnUs (Condition False cond code__2) - -condIntCode cond [x, y] = - 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] . - mkSeqInstr (SUB False True src1 (RIReg src2) g0) - in - returnUs (Condition False cond code__2) - -condFltCode cond [x, y] = - getReg x `thenUs` \ register1 -> - getReg y `thenUs` \ register2 -> - getNewRegNCG (registerKind register1) - `thenUs` \ tmp1 -> - getNewRegNCG (registerKind register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - let - promote x = asmInstr (FxTOy F DF x tmp) - - pk1 = registerKind register1 - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - pk2 = registerKind register2 - code2 = registerCode register2 tmp2 - src2 = registerName register2 tmp2 - - code__2 = - if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (FCMP True (kindToSize pk1) src1 src2) - else if pk1 == FloatRep then - asmParThen [code1 (promote src1), code2 asmVoid] . - mkSeqInstr (FCMP True DF tmp src2) - else - asmParThen [code1 asmVoid, code2 (promote src2)] . - mkSeqInstr (FCMP True DF src1 tmp) - in - returnUs (Condition True cond code__2) - -\end{code} - -Turn those condition codes into integers now (when they appear on -the right hand side of an assignment). - -Do not fill the delay slots here; you will confuse the register allocator. - -\begin{code} - -condIntReg :: Cond -> [StixTree] -> UniqSM Register - -condIntReg EQ [x, StInt 0] = - 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 - returnUs (Any IntRep code__2) - -condIntReg EQ [x, y] = - 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 [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] - in - returnUs (Any IntRep code__2) - -condIntReg NE [x, StInt 0] = - 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 - returnUs (Any IntRep code__2) - -condIntReg NE [x, y] = - 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 [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] - in - returnUs (Any IntRep code__2) - -condIntReg cond args = - getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condIntCode cond args `thenUs` \ condition -> - let - 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, - LABEL lbl1, - OR False g0 (RIImm (ImmInt 1)) dst, - LABEL lbl2] - in - returnUs (Any IntRep code__2) - -condFltReg :: Cond -> [StixTree] -> UniqSM Register - -condFltReg cond args = - getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condFltCode cond args `thenUs` \ condition -> - let - code = condCode condition - cond = condName condition - code__2 dst = code . mkSeqInstrs [ - NOP, - BF cond False (ImmCLbl lbl1), NOP, - OR False g0 (RIImm (ImmInt 0)) dst, - BI ALWAYS False (ImmCLbl lbl2), NOP, - LABEL lbl1, - OR False g0 (RIImm (ImmInt 1)) dst, - LABEL lbl2] - in - returnUs (Any IntRep code__2) - -\end{code} - -Assignments are really at the heart of the whole code generation business. -Almost all top-level nodes of any real importance are assignments, which -correspond to loads, stores, or register transfers. If we're really lucky, -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). - -\begin{code} - -assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr) - -assignIntCode pk (StInd _ dst) src = - 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 - src__2 = registerName register tmp - sz = kindToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) - in - returnUs code__2 - -assignIntCode pk dst src = - 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 . mkSeqInstr (OR False g0 (RIReg src__2) dst__2) - else code - in - returnUs code__2 - -assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr) - -assignFltCode pk (StInd _ dst) src = - getNewRegNCG pk `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getReg src `thenUs` \ register -> - let - sz = kindToSize pk - dst__2 = amodeAddr amode - - code1 = amodeCode amode asmVoid - code2 = registerCode register tmp asmVoid - - src__2 = registerName register tmp - pk__2 = registerKind register - sz__2 = kindToSize pk__2 - - 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 - returnUs code__2 - -assignFltCode pk dst src = - getReg dst `thenUs` \ register1 -> - getReg src `thenUs` \ register2 -> - getNewRegNCG (registerKind register2) - `thenUs` \ tmp -> - let - sz = kindToSize pk - dst__2 = registerName register1 g0 -- must be Fixed - - reg__2 = if pk /= pk__2 then tmp else dst__2 - - code = registerCode register2 reg__2 - src__2 = registerName register2 reg__2 - pk__2 = registerKind register2 - sz__2 = kindToSize pk__2 - - code__2 = if pk /= pk__2 then code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2) - else if isFixed register2 then code . mkSeqInstr (FMOV sz src__2 dst__2) - else code - in - returnUs code__2 - -\end{code} - -Generating an unconditional branch. We accept two types of targets: -an immediate CLabel or a tree that gets evaluated into a register. -Any CLabels which are AsmTemporaries are assumed to be in the local -block of code, close enough for a branch instruction. Other CLabels -are assumed to be far away, so we use call. - -Do not fill the delay slots here; you will confuse the register allocator. - -\begin{code} - -genJump - :: StixTree -- the branch target - -> UniqSM (CodeBlock SparcInstr) - -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 `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> - let - code = registerCode register tmp - target = registerName register tmp - in - returnSeq code [JMP (AddrRegReg target g0), NOP] - -\end{code} - -Conditional jumps are always to local labels, so we can use -branch instructions. First, we have to ensure that the condition -codes are set according to the supplied comparison operation. -We generate slightly different code for floating point comparisons, -because a floating point operation cannot directly precede a @BF@. -We assume the worst and fill that slot with a @NOP@. - -Do not fill the delay slots here; you will confuse the register allocator. - -\begin{code} - -genCondJump - :: CLabel -- the branch target - -> StixTree -- the condition on which to branch - -> UniqSM (CodeBlock SparcInstr) - -genCondJump lbl bool = - getCondition bool `thenUs` \ condition -> - let - code = condCode condition - cond = condName condition - target = ImmCLbl lbl - in - if condFloat condition then - returnSeq code [NOP, BF cond False target, NOP] - else - returnSeq code [BI cond False target, NOP] - -\end{code} - -Now the biggest nightmare---calls. Most of the nastiness is buried in -getCallArg, which moves the arguments to the correct registers/stack -locations. Apart from that, the code is easy. - -Do not fill the delay slots here; you will confuse the register allocator. - -\begin{code} - -genCCall - :: FAST_STRING -- function to call - -> PrimRep -- type of the result - -> [StixTree] -- arguments (of mixed type) - -> UniqSM (CodeBlock SparcInstr) - -genCCall fn kind args = - mapAccumLNCG getCallArg (argRegs,stackArgLoc) args - `thenUs` \ ((unused,_), argCode) -> - let - nRegs = length argRegs - length unused - call = CALL fn__2 nRegs False - code = asmParThen (map ($ asmVoid) argCode) - in - returnSeq code [call, NOP] - where - -- function names that begin with '.' are assumed to be special internally - -- generated names like '.mul,' which don't get an underscore prefix - fn__2 = case (_HEAD_ fn) of - '.' -> ImmLit (uppPStr fn) - _ -> ImmLab (uppPStr fn) - - 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} - -Trivial (dyadic) instructions. Only look for constants on the right hand -side, because that's where the generic optimizer will have put them. - -\begin{code} - -trivialCode - :: (Reg -> RI -> Reg -> SparcInstr) - -> [StixTree] - -> UniqSM Register - -trivialCode instr [x, StInt y] - | is13Bits y = - 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 - returnUs (Any IntRep code__2) - -trivialCode instr [x, y] = - 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 (instr src1 (RIReg src2) dst) - in - returnUs (Any IntRep code__2) - -trivialFCode - :: PrimRep - -> (Size -> Reg -> Reg -> Reg -> SparcInstr) - -> [StixTree] - -> UniqSM Register - -trivialFCode pk instr [x, y] = - getReg x `thenUs` \ register1 -> - getReg y `thenUs` \ register2 -> - getNewRegNCG (registerKind register1) - `thenUs` \ tmp1 -> - getNewRegNCG (registerKind register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - let - promote x = asmInstr (FxTOy F DF x tmp) - - pk1 = registerKind register1 - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - pk2 = registerKind register2 - code2 = registerCode register2 tmp2 - src2 = registerName register2 tmp2 - - code__2 dst = - if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (instr (kindToSize pk) src1 src2 dst) - 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 - returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) - -\end{code} - -Trivial unary instructions. Note that we don't have to worry about -matching an StInt as the argument, because genericOpt will already -have handled the constant-folding. - -\begin{code} - -trivialUCode - :: (RI -> Reg -> SparcInstr) - -> [StixTree] - -> UniqSM Register - -trivialUCode instr [x] = - 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 - returnUs (Any IntRep code__2) - -trivialUFCode - :: PrimRep - -> (Reg -> Reg -> SparcInstr) - -> [StixTree] - -> UniqSM Register - -trivialUFCode pk instr [x] = - 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 - returnUs (Any pk code__2) - -\end{code} - -Absolute value on integers, mostly for gmp size check macros. Again, -the argument cannot be an StInt, because genericOpt already folded -constants. - -Do not fill the delay slots here; you will confuse the register allocator. - -\begin{code} - -absIntCode :: [StixTree] -> UniqSM Register -absIntCode [x] = - 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] - in - 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 :: PrimRep -> [StixTree] -> UniqSM Register -coerceIntCode pk [x] = - getReg x `thenUs` \ register -> - case register of - Fixed reg _ code -> returnUs (Fixed reg pk code) - Any _ code -> returnUs (Any pk code) - -\end{code} - -Integer to character conversion. We try to do this in one step if -the original object is in memory. - -\begin{code} - -chrCode :: [StixTree] -> UniqSM Register -chrCode [StInd pk mem] = - getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - srcOff = offset src 3 - src__2 = case srcOff of Just x -> x - code__2 dst = if maybeToBool srcOff then - code . mkSeqInstr (LD UB src__2 dst) - else - code . mkSeqInstrs [ - LD (kindToSize pk) src dst, - AND False dst (RIImm (ImmInt 255)) dst] - in - returnUs (Any pk code__2) - -chrCode [x] = - 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 - returnUs (Any IntRep code__2) - -\end{code} - -More complicated integer/float conversions. Here we have to store -temporaries in memory to move between the integer and the floating -point register sets. - -\begin{code} - -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 [ - ST W src (spRel (-2)), - LD W (spRel (-2)) dst, - FxTOy W (kindToSize pk) dst dst] - in - returnUs (Any pk code__2) - -coerceFP2Int :: [StixTree] -> UniqSM Register -coerceFP2Int [x] = - getReg x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> - getNewRegNCG FloatRep `thenUs` \ tmp -> - let - code = registerCode register reg - src = registerName register reg - pk = registerKind register - - code__2 dst = code . mkSeqInstrs [ - FxTOy (kindToSize pk) W src tmp, - ST W tmp (spRel (-2)), - LD W (spRel (-2)) dst] - in - returnUs (Any IntRep code__2) - -\end{code} - -Some random little helpers. - -\begin{code} - -maybeImm :: StixTree -> Maybe Imm -maybeImm (StInt i) - | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i)) - | otherwise = Just (ImmInteger i) -maybeImm (StLitLbl s) = Just (ImmLab s) -maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s))) -maybeImm (StCLbl l) = Just (ImmCLbl l) -maybeImm _ = Nothing - -mangleIndexTree :: StixTree -> StixTree - -mangleIndexTree (StIndex pk base (StInt i)) = - StPrim IntAddOp [base, off] - where - off = StInt (i * size pk) - 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) = - case pk of - CharRep -> StPrim IntAddOp [base, off] - _ -> StPrim IntAddOp [base, off__2] - where - off__2 = StPrim SllOp [off, StInt (shift pk)] - 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 - | isHex s = s - | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''") - where - isHex ('0':'x':xs) = all isHexDigit xs - isHex _ = False - -- Now, where have I seen this before? - isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' - - -\end{code} - -spRel gives us a stack relative addressing mode for volatile temporaries -and for excess call arguments. - -\begin{code} - -spRel - :: Int -- desired stack offset in words, positive or negative - -> Addr -spRel n = AddrRegImm sp (ImmInt (n * 4)) - -stackArgLoc = 23 :: Int -- where to stack extra call arguments (beyond 6x32 bits) - -\end{code} - -\begin{code} - -getNewRegNCG :: PrimRep -> UniqSM Reg -getNewRegNCG pk = - getUnique `thenUs` \ u -> - returnUs (mkReg u pk) - -\end{code} diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 8269dbd..f187e9f 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \begin{code} @@ -11,158 +11,142 @@ module Stix ( stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg, --- stgActivityReg, stgStdUpdRetVecReg, stgStkStubReg, getUniqLabelNCG - - -- And for self-sufficiency, by golly... ) where -import AbsCSyn ( MagicId(..), kindFromMagicId, node, infoptr ) -import PrelInfo ( showPrimOp, PrimOp - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import CLabel ( CLabel, mkAsmTempLabel ) -import Outputable -import UniqSupply -import Unpretty -import Util +import Ubiq{-uitous-} + +import AbsCSyn ( node, infoptr, MagicId(..) ) +import AbsCUtils ( magicIdPrimRep ) +import CLabel ( mkAsmTempLabel ) +import UniqSupply ( returnUs, thenUs, getUnique, UniqSM(..) ) +import Unpretty ( uppPStr, Unpretty(..) ) \end{code} Here is the tag at the nodes of our @StixTree@. Notice its relationship with @PrimOp@ in prelude/PrimOp. \begin{code} +data StixTree + = -- Segment (text or data) -data StixTree = - - -- Segment (text or data) + StSegment CodeSegment - StSegment CodeSegment + -- We can tag the leaves with constants/immediates. - -- We can tag the leaves with constants/immediates. + | StInt Integer -- ** add Kind at some point + | StDouble Rational + | StString FAST_STRING + | StLitLbl Unpretty -- literal labels + -- (will be _-prefixed on some machines) + | StLitLit FAST_STRING -- innards from CLitLit + | StCLbl CLabel -- labels that we might index into - | StInt Integer -- ** add Kind at some point - | StDouble Rational - | StString FAST_STRING - | StLitLbl Unpretty -- literal labels (will be _-prefixed on some machines) - | StLitLit FAST_STRING -- innards from CLitLit - | StCLbl CLabel -- labels that we might index into + -- Abstract registers of various kinds - -- Abstract registers of various kinds + | StReg StixReg - | StReg StixReg + -- A typed offset from a base location - -- A typed offset from a base location + | StIndex PrimRep StixTree StixTree -- kind, base, offset - | StIndex PrimRep StixTree StixTree -- kind, base, offset + -- An indirection from an address to its contents. - -- An indirection from an address to its contents. + | StInd PrimRep StixTree - | StInd PrimRep StixTree + -- Assignment is typed to determine size and register placement - -- Assignment is typed to determine size and register placement + | StAssign PrimRep StixTree StixTree -- dst, src - | StAssign PrimRep StixTree StixTree -- dst, src + -- A simple assembly label that we might jump to. - -- A simple assembly label that we might jump to. + | StLabel CLabel - | StLabel CLabel + -- A function header and footer - -- A function header and footer + | StFunBegin CLabel + | StFunEnd CLabel - | StFunBegin CLabel - | StFunEnd CLabel + -- An unconditional jump. This instruction is terminal. + -- Dynamic targets are allowed - -- An unconditional jump. This instruction is terminal. - -- Dynamic targets are allowed + | StJump StixTree - | StJump StixTree + -- A fall-through, from slow to fast - -- A fall-through, from slow to fast + | StFallThrough CLabel - | StFallThrough CLabel + -- A conditional jump. This instruction can be non-terminal :-) + -- Only static, local, forward labels are allowed - -- A conditional jump. This instruction can be non-terminal :-) - -- Only static, local, forward labels are allowed + | StCondJump CLabel StixTree - | StCondJump CLabel StixTree + -- Raw data (as in an info table). - -- Raw data (as in an info table). + | StData PrimRep [StixTree] - | StData PrimRep [StixTree] + -- Primitive Operations - -- Primitive Operations + | StPrim PrimOp [StixTree] - | StPrim PrimOp [StixTree] + -- Calls to C functions - -- Calls to C functions + | StCall FAST_STRING PrimRep [StixTree] - | StCall FAST_STRING PrimRep [StixTree] + -- Assembly-language comments - -- Comments, of course - - | StComment FAST_STRING -- For assembly comments - - deriving () + | StComment FAST_STRING sStLitLbl :: FAST_STRING -> StixTree sStLitLbl s = StLitLbl (uppPStr s) \end{code} Stix registers can have two forms. They {\em may} or {\em may not} -map to real, machine level registers. +map to real, machine-level registers. \begin{code} +data StixReg + = StixMagicId MagicId -- Regs which are part of the abstract machine model -data StixReg = StixMagicId MagicId -- Regs which are part of the abstract machine model - - | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in + | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in -- the abstract C. - deriving () - \end{code} We hope that every machine supports the idea of data segment and text -segment (or that it has no segments at all, and we can lump these together). +segment (or that it has no segments at all, and we can lump these +together). \begin{code} - -data CodeSegment = DataSegment | TextSegment deriving (Eq) +data CodeSegment = DataSegment | TextSegment deriving Eq type StixTreeList = [StixTree] -> [StixTree] - \end{code} --- Stix Trees for STG registers - +Stix Trees for STG registers: \begin{code} - -stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA, stgSuA, - stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg{-, stgActivityReg-}, stgStdUpdRetVecReg, - stgStkStubReg :: StixTree - -stgBaseReg = StReg (StixMagicId BaseReg) -stgStkOReg = StReg (StixMagicId StkOReg) -stgNode = StReg (StixMagicId node) -stgInfoPtr = StReg (StixMagicId infoptr) -stgTagReg = StReg (StixMagicId TagReg) -stgRetReg = StReg (StixMagicId RetReg) -stgSpA = StReg (StixMagicId SpA) -stgSuA = StReg (StixMagicId SuA) -stgSpB = StReg (StixMagicId SpB) -stgSuB = StReg (StixMagicId SuB) -stgHp = StReg (StixMagicId Hp) -stgHpLim = StReg (StixMagicId HpLim) -stgLivenessReg = StReg (StixMagicId LivenessReg) ---stgActivityReg = StReg (StixMagicId ActivityReg) -stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg) -stgStkStubReg = StReg (StixMagicId StkStubReg) +stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA, + stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg, + stgStdUpdRetVecReg, stgStkStubReg :: StixTree + +stgBaseReg = StReg (StixMagicId BaseReg) +stgStkOReg = StReg (StixMagicId StkOReg) +stgNode = StReg (StixMagicId node) +stgInfoPtr = StReg (StixMagicId infoptr) +stgTagReg = StReg (StixMagicId TagReg) +stgRetReg = StReg (StixMagicId RetReg) +stgSpA = StReg (StixMagicId SpA) +stgSuA = StReg (StixMagicId SuA) +stgSpB = StReg (StixMagicId SpB) +stgSuB = StReg (StixMagicId SuB) +stgHp = StReg (StixMagicId Hp) +stgHpLim = StReg (StixMagicId HpLim) +stgLivenessReg = StReg (StixMagicId LivenessReg) +stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg) +stgStkStubReg = StReg (StixMagicId StkStubReg) getUniqLabelNCG :: UniqSM CLabel -getUniqLabelNCG = - getUnique `thenUs` \ u -> - returnUs (mkAsmTempLabel u) - +getUniqLabelNCG + = getUnique `thenUs` \ u -> + returnUs (mkAsmTempLabel u) \end{code} diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index e827167..82b88c6 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -1,24 +1,32 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \begin{code} #include "HsVersions.h" -module StixInfo ( - genCodeInfoTable - ) where - -import AbsCSyn -import ClosureInfo -import MachDesc -import Maybes ( maybeToBool, Maybe(..) ) -import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) -import Stix -import UniqSupply -import Unpretty -import Util - +module StixInfo ( genCodeInfoTable ) where + +import Ubiq{-uitious-} + +import AbsCSyn ( AbstractC(..), CAddrMode, ReturnInfo, + RegRelative, MagicId, CStmtMacro + ) +import ClosureInfo ( closurePtrsSize, closureSizeWithoutFixedHdr, + closureNonHdrSize, closureSemiTag, maybeSelectorInfo, + closureSMRep, closureLabelFromCI, + infoTableLabelFromCI + ) +import HeapOffs ( hpRelToInt ) +import Maybes ( maybeToBool ) +import PrimRep ( PrimRep(..) ) +import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..), + isSpecRep + ) +import Stix -- all of it +import StixPrim ( amodeToStix ) +import UniqSupply ( returnUs, UniqSM(..) ) +import Unpretty ( uppBesides, uppPStr, uppInt, uppChar ) \end{code} Generating code for info tables (arrays of data). @@ -36,14 +44,11 @@ data___rtbl = sStLitLbl SLIT("Data___rtbl") dyn___rtbl = sStLitLbl SLIT("Dyn___rtbl") genCodeInfoTable - :: {-Target-} - (HeapOffset -> Int) -- needed bit of Target - -> (CAddrMode -> StixTree) -- ditto - -> AbstractC + :: AbstractC -> UniqSM StixTreeList -genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr _) = - returnUs (\xs -> info : lbl : xs) +genCodeInfoTable (CClosureInfoAndCode cl_info _ _ upd cl_descr _) + = returnUs (\xs -> info : lbl : xs) where info = StData PtrRep table @@ -133,11 +138,10 @@ genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr size = if isSpecRep sm_rep then closureNonHdrSize cl_info - else hp_rel (closureSizeWithoutFixedHdr cl_info) + else hpRelToInt (closureSizeWithoutFixedHdr cl_info) ptrs = closurePtrsSize cl_info - upd_code = amode2stix upd + upd_code = amodeToStix upd info_unused = StInt (-1) - \end{code} diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 91d68d0..fe9ec74 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -1,38 +1,41 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \begin{code} #include "HsVersions.h" module StixInteger ( - gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, - gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer, + 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 PrelInfo ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind(..) ) -import Stix -import UniqSupply -import Util - +import Ubiq{-uitous-} +import NcgLoop ( amodeToStix ) + +import MachMisc +import MachRegs + +import AbsCSyn -- bits and bobs... +import CgCompInfo ( mIN_MP_INT_SIZE ) +import Literal ( Literal(..) ) +import OrdList ( OrdList ) +import PrimOp ( PrimOp(..) ) +import PrimRep ( PrimRep(..) ) +import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind ) +import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim, + StixTree(..), StixTreeList(..), + CodeSegment, StixReg + ) +import StixMacro ( macroCode, heapCheck ) +import UniqSupply ( returnUs, thenUs, UniqSM(..) ) +import Util ( panic ) \end{code} \begin{code} - gmpTake1Return1 - :: Target - -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts) + :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts) -> FAST_STRING -- function name -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- argument (4 parts) @@ -47,124 +50,109 @@ 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 _ _ _ _ _ _ _ _) - -gmpTake1Return1 target_STRICT res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) = - let - a2stix = amodeToStix target - data_hs = dataHS target - - ar = a2stix car - sr = a2stix csr - dr = a2stix cdr - liveness= a2stix clive - aa = a2stix caa - sa = a2stix csa - da = a2stix cda - - space = mpSpace data_hs 2 1 [sa] +gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) + = let + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr + liveness= amodeToStix clive + aa = amodeToStix caa + sa = amodeToStix csa + da = amodeToStix cda + + space = mpSpace 2 1 [sa] oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space]) - safeHp = saveLoc target Hp + safeHp = saveLoc Hp save = StAssign PtrRep safeHp oldHp - (a1,a2,a3) = toStruct data_hs argument1 (aa,sa,da) + (a1,a2,a3) = toStruct argument1 (aa,sa,da) mpz_op = StCall rtn VoidRep [result2, argument1] restore = StAssign PtrRep stgHp safeHp - (r1,r2,r3) = fromStruct data_hs result2 (ar,sr,dr) + (r1,r2,r3) = fromStruct result2 (ar,sr,dr) in - heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk -> + heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> - returnUs (heap_chk . - (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs)) + returnUs (heap_chk . + (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs)) gmpTake2Return1 - :: Target - -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts) + :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts) -> FAST_STRING -- function name -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) -- liveness + 2 arguments (3 parts each) -> UniqSM StixTreeList -gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) = - let - a2stix = amodeToStix target - data_hs = dataHS target - - ar = a2stix car - sr = a2stix csr - dr = a2stix cdr - liveness= a2stix clive - aa1 = a2stix caa1 - sa1 = a2stix csa1 - da1 = a2stix cda1 - aa2 = a2stix caa2 - sa2 = a2stix csa2 - da2 = a2stix cda2 - - space = mpSpace data_hs 3 1 [sa1, sa2] +gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) + = let + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr + liveness= amodeToStix clive + aa1 = amodeToStix caa1 + sa1 = amodeToStix csa1 + da1 = amodeToStix cda1 + aa2 = amodeToStix caa2 + sa2 = amodeToStix csa2 + da2 = amodeToStix cda2 + + space = mpSpace 3 1 [sa1, sa2] oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space]) - safeHp = saveLoc target Hp + safeHp = saveLoc Hp 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) + (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2) mpz_op = StCall rtn VoidRep [result3, argument1, argument2] restore = StAssign PtrRep stgHp safeHp - (r1,r2,r3) = fromStruct data_hs result3 (ar,sr,dr) + (r1,r2,r3) = fromStruct result3 (ar,sr,dr) in - heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk -> + heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> - returnUs (heap_chk . - (\xs -> a1 : a2 : a3 : a4 : a5 : a6 - : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs)) + returnUs (heap_chk . + (\xs -> a1 : a2 : a3 : a4 : a5 : a6 + : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs)) gmpTake2Return2 - :: Target - -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + :: (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) -> UniqSM StixTreeList -gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2) - rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) = - let - 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 - liveness= a2stix clive - 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] +gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2) + rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) + = let + ar1 = amodeToStix car1 + sr1 = amodeToStix csr1 + dr1 = amodeToStix cdr1 + ar2 = amodeToStix car2 + sr2 = amodeToStix csr2 + dr2 = amodeToStix cdr2 + liveness= amodeToStix clive + aa1 = amodeToStix caa1 + sa1 = amodeToStix csa1 + da1 = amodeToStix cda1 + aa2 = amodeToStix caa2 + sa2 = amodeToStix csa2 + da2 = amodeToStix cda2 + + space = StPrim IntMulOp [mpSpace 2 1 [sa1, sa2], StInt 2] oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space]) - safeHp = saveLoc target Hp + safeHp = saveLoc Hp 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) + (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2) 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) + (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1) + (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2) in - heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk -> - - returnUs (heap_chk . - (\xs -> a1 : a2 : a3 : a4 : a5 : a6 - : save : init3 : init4 : mpz_op - : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs)) + heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> + 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} Although gmpCompare doesn't allocate space, it does temporarily use @@ -173,92 +161,79 @@ enclosing routine has already guaranteed that this space will be available. (See ``primOpHeapRequired.'') \begin{code} - gmpCompare - :: Target - -> CAddrMode -- result (boolean) + :: CAddrMode -- result (boolean) -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) -- alloc hp + 2 arguments (3 parts each) -> UniqSM StixTreeList -gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) = - let - a2stix = amodeToStix target - data_hs = dataHS target - - result = a2stix res - hp = a2stix chp - aa1 = a2stix caa1 - sa1 = a2stix csa1 - da1 = a2stix cda1 - aa2 = a2stix caa2 - sa2 = a2stix csa2 - da2 = a2stix cda2 +gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) + = let + result = amodeToStix res + hp = amodeToStix chp + aa1 = amodeToStix caa1 + sa1 = amodeToStix csa1 + da1 = amodeToStix cda1 + aa2 = amodeToStix caa2 + sa2 = amodeToStix csa2 + da2 = amodeToStix cda2 argument1 = hp 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) + (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2) mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2] r1 = StAssign IntRep result mpz_cmp in - returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs) - + returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs) \end{code} See the comment above regarding the heap check (or lack thereof). \begin{code} - gmpInteger2Int - :: Target - -> CAddrMode -- result + :: CAddrMode -- result -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts) -> UniqSM StixTreeList -gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) = - let - a2stix = amodeToStix target - data_hs = dataHS target +gmpInteger2Int res args@(chp, caa,csa,cda) + = let + result = amodeToStix res + hp = amodeToStix chp + aa = amodeToStix caa + sa = amodeToStix csa + da = amodeToStix cda - result = a2stix res - hp = a2stix chp - aa = a2stix caa - sa = a2stix csa - da = a2stix cda - - (a1,a2,a3) = toStruct data_hs hp (aa,sa,da) + (a1,a2,a3) = toStruct hp (aa,sa,da) mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp] r1 = StAssign IntRep result mpz_get_si in - returnUs (\xs -> a1 : a2 : a3 : r1 : xs) + returnUs (\xs -> a1 : a2 : a3 : r1 : xs) arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") +-------------- gmpInt2Integer - :: Target - -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts) + :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts) -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert -> UniqSM StixTreeList -gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) = - getUniqLabelNCG `thenUs` \ zlbl -> +gmpInt2Integer res@(car,csr,cdr) args@(chp, n) + = 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 - i = a2stix n + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr + hp = amodeToStix chp + i = amodeToStix n h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info - size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE + size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1))) (StInt (toInteger size)) - cts = StInd IntRep (StIndex IntRep hp (dataHS target)) + cts = StInd IntRep (StIndex IntRep hp dataHS) test1 = StPrim IntEqOp [i, StInt 0] test2 = StPrim IntLtOp [i, StInt 0] cjmp1 = StCondJump zlbl test1 @@ -280,84 +255,75 @@ gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) = a1 = StAssign IntRep ar (StInt 1) a2 = StAssign PtrRep dr hp in - returnUs (\xs -> - case n of - 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 - : a0 : a1 : a2 : xs) + returnUs (\xs -> + case n of + 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 + : a0 : a1 : a2 : xs) gmpString2Integer - :: Target - -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts) + :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts) -> (CAddrMode, CAddrMode) -- liveness, string -> UniqSM StixTreeList -gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) = - getUniqLabelNCG `thenUs` \ ulbl -> +gmpString2Integer res@(car,csr,cdr) (liveness, str) + = getUniqLabelNCG `thenUs` \ ulbl -> let - a2stix = amodeToStix target - data_hs = dataHS target - - ar = a2stix car - sr = a2stix csr - dr = a2stix cdr + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr len = case str of (CString s) -> _LENGTH_ s (CLit (MachStr s)) -> _LENGTH_ s _ -> panic "String2Integer" space = len `quot` 8 + 17 + mpIntSize + - varHeaderSize target (DataRep 0) + fixedHeaderSize target + varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space))) - safeHp = saveLoc target Hp + safeHp = saveLoc Hp 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] + [result, amodeToStix str, StInt 10] test = StPrim IntEqOp [set_str, StInt 0] cjmp = StCondJump ulbl test abort = StCall SLIT("abort") VoidRep [] join = StLabel ulbl restore = StAssign PtrRep stgHp safeHp - (a1,a2,a3) = fromStruct data_hs result (ar,sr,dr) + (a1,a2,a3) = fromStruct result (ar,sr,dr) in - macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0] - `thenUs` \ heap_chk -> + macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0] + `thenUs` \ heap_chk -> - returnUs (heap_chk . - (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs)) + returnUs (heap_chk . + (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs)) mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) encodeFloatingKind :: PrimRep - -> Target -> CAddrMode -- result -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) -- heap pointer for result, integer argument (3 parts), exponent -> UniqSM StixTreeList -encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) = - let - a2stix = amodeToStix target - size_of = sizeof target - data_hs = dataHS target - - result = a2stix res - hp = a2stix chp - aa = a2stix caa - sa = a2stix csa - da = a2stix cda - expon = a2stix cexpon - - pk' = if size_of FloatRep == size_of DoubleRep +encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon) + = let + result = amodeToStix res + hp = amodeToStix chp + aa = amodeToStix caa + sa = amodeToStix csa + da = amodeToStix cda + expon = amodeToStix cexpon + + pk' = if sizeOf FloatRep == sizeOf DoubleRep then DoubleRep else pk - (a1,a2,a3) = toStruct data_hs hp (aa,sa,da) + (a1,a2,a3) = toStruct hp (aa,sa,da) fn = case pk' of FloatRep -> SLIT("__encodeFloat") DoubleRep -> SLIT("__encodeDouble") @@ -365,31 +331,26 @@ encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) = encode = StCall fn pk' [hp, expon] r1 = StAssign pk' result encode in - returnUs (\xs -> a1 : a2 : a3 : r1 : xs) + returnUs (\xs -> a1 : a2 : a3 : r1 : xs) decodeFloatingKind :: PrimRep - -> Target -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -- exponent result, integer result (3 parts) -> (CAddrMode, CAddrMode) -- heap pointer for exponent, floating argument -> UniqSM StixTreeList -decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) = - let - a2stix = amodeToStix target - 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 FloatRep == size_of DoubleRep +decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg) + = let + exponr = amodeToStix cexponr + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr + hp = amodeToStix chp + arg = amodeToStix carg + + pk' = if sizeOf FloatRep == sizeOf DoubleRep then DoubleRep else pk setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1)) @@ -398,10 +359,10 @@ decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) = DoubleRep -> SLIT("__decodeDouble") _ -> panic "decodeFloatingKind" decode = StCall fn VoidRep [mantissa, hp, arg] - (a1,a2,a3) = fromStruct data_hs mantissa (ar,sr,dr) + (a1,a2,a3) = fromStruct mantissa (ar,sr,dr) a4 = StAssign IntRep exponr (StInd IntRep hp) in - returnUs (\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 @@ -410,7 +371,6 @@ mpData_mantissa = mpData mantissa Support for the Gnu GMP multi-precision package. \begin{code} - mpIntSize = 3 :: Int mpAlloc, mpSize, mpData :: StixTree -> StixTree @@ -419,57 +379,54 @@ mpSize base = StInd IntRep (StIndex IntRep base (StInt 1)) mpData base = StInd PtrRep (StIndex IntRep base (StInt 2)) mpSpace - :: StixTree -- dataHs from Target - -> Int -- gmp structures needed + :: 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 = - foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes +mpSpace gmp res sizes + = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes where sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y] fixed = StInt (toInteger (17 * res + gmp * mpIntSize)) - hdrs = StPrim IntMulOp [data_hs, StInt (toInteger res)] - + hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)] \end{code} -We don't have a truly portable way of allocating local temporaries, so we -cheat and use space at the end of the heap. (Thus, negative offsets from -HpLim are our temporaries.) Note that you must have performed a heap check -which includes the space needed for these temporaries before you use them. +We don't have a truly portable way of allocating local temporaries, so +we cheat and use space at the end of the heap. (Thus, negative +offsets from HpLim are our temporaries.) Note that you must have +performed a heap check which includes the space needed for these +temporaries before you use them. \begin{code} mpStruct :: Int -> StixTree mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize)))) toStruct - :: StixTree -- dataHS, from Target - -> StixTree + :: StixTree -> (StixTree, StixTree, StixTree) -> (StixTree, StixTree, StixTree) -toStruct data_hs str (alloc,size,arr) = - let +toStruct str (alloc,size,arr) + = let f1 = StAssign IntRep (mpAlloc str) alloc f2 = StAssign IntRep (mpSize str) size - f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr data_hs) + f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS) in - (f1, f2, f3) + (f1, f2, f3) fromStruct - :: StixTree -- dataHS, from Target - -> StixTree + :: StixTree -> (StixTree, StixTree, StixTree) -> (StixTree, StixTree, StixTree) -fromStruct data_hs str (alloc,size,arr) = - let +fromStruct str (alloc,size,arr) + = let e1 = StAssign IntRep alloc (mpAlloc str) e2 = StAssign IntRep size (mpSize str) e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str) - (StPrim IntNegOp [data_hs])) + (StPrim IntNegOp [dataHS])) in - (e1, e2, e3) + (e1, e2, e3) \end{code} diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index b244110..4e7b47f 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -1,27 +1,27 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \begin{code} #include "HsVersions.h" -module StixMacro ( - genMacroCode, doHeapCheck, smStablePtrTable, +module StixMacro ( macroCode, heapCheck ) where - Target, StixTree, UniqSupply, CAddrMode, CExprMacro, - CStmtMacro - ) where +import Ubiq{-uitious-} +import NcgLoop ( amodeToStix ) -import AbsCSyn -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 MachMisc +import MachRegs + +import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode ) +import CgCompInfo ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE, + sTD_UF_SIZE + ) +import OrdList ( OrdList ) +import PrimOp ( PrimOp(..) ) +import PrimRep ( PrimRep(..) ) import Stix -import UniqSupply -import Util +import UniqSupply ( returnUs, thenUs, UniqSM(..) ) \end{code} The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on @@ -33,43 +33,31 @@ closure address. mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) mkIntCLit_3 = mkIntCLit 3 --- hacking with Uncle Will: -#define target_STRICT target@(Target _ _ _ _ _ _ _ _) - -genMacroCode - :: Target - -> CStmtMacro -- statement macro +macroCode + :: CStmtMacro -- statement macro -> [CAddrMode] -- args -> UniqSM StixTreeList -genMacroCode target_STRICT macro args - = genmacro macro args - where - a2stix = amodeToStix target - stg_reg = stgReg target - - -- real thing: here we go ----------------------- - - genmacro ARGS_CHK_A_LOAD_NODE args = - getUniqLabelNCG `thenUs` \ ulbl -> - let [words, lbl] = map a2stix args - temp = StIndex PtrRep stgSpA words - test = StPrim AddrGeOp [stgSuA, temp] - cjmp = StCondJump ulbl test - assign = StAssign PtrRep stgNode lbl - join = StLabel ulbl +macroCode ARGS_CHK_A_LOAD_NODE args + = getUniqLabelNCG `thenUs` \ ulbl -> + let + [words, lbl] = map amodeToStix args + temp = StIndex PtrRep stgSpA words + test = StPrim AddrGeOp [stgSuA, temp] + cjmp = StCondJump ulbl test + assign = StAssign PtrRep stgNode lbl + join = StLabel ulbl in - returnUs (\xs -> cjmp : assign : updatePAP : join : xs) + returnUs (\xs -> cjmp : assign : updatePAP : join : xs) - genmacro ARGS_CHK_A [words] = - getUniqLabelNCG `thenUs` \ ulbl -> - let temp = StIndex PtrRep stgSpA (a2stix words) +macroCode ARGS_CHK_A [words] + = getUniqLabelNCG `thenUs` \ ulbl -> + let temp = StIndex PtrRep stgSpA (amodeToStix words) test = StPrim AddrGeOp [stgSuA, temp] cjmp = StCondJump ulbl test join = StLabel ulbl in - returnUs (\xs -> cjmp : updatePAP : join : xs) - + returnUs (\xs -> cjmp : updatePAP : join : xs) \end{code} Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for @@ -79,43 +67,43 @@ also loads R1 with an appropriate closure address. Note that the directions are swapped relative to the A stack. \begin{code} - - genmacro ARGS_CHK_B_LOAD_NODE args = - getUniqLabelNCG `thenUs` \ ulbl -> - let [words, lbl] = map a2stix args +macroCode ARGS_CHK_B_LOAD_NODE args + = getUniqLabelNCG `thenUs` \ ulbl -> + let + [words, lbl] = map amodeToStix args temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words]) test = StPrim AddrGeOp [stgSpB, temp] cjmp = StCondJump ulbl test assign = StAssign PtrRep stgNode lbl join = StLabel ulbl in - returnUs (\xs -> cjmp : assign : updatePAP : join : xs) + returnUs (\xs -> cjmp : assign : updatePAP : join : xs) - genmacro ARGS_CHK_B [words] = - getUniqLabelNCG `thenUs` \ ulbl -> - let temp = StIndex PtrRep stgSuB (StPrim IntNegOp [a2stix words]) +macroCode ARGS_CHK_B [words] + = getUniqLabelNCG `thenUs` \ ulbl -> + let + temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words]) test = StPrim AddrGeOp [stgSpB, temp] cjmp = StCondJump ulbl test join = StLabel ulbl in - returnUs (\xs -> cjmp : updatePAP : join : xs) - + returnUs (\xs -> cjmp : updatePAP : join : xs) \end{code} The @HEAP_CHK@ macro checks to see that there are enough words available in the heap (before reaching @HpLim@). When a heap check fails, it has to call @PerformGC@ via the @PerformGC_wrapper@. The -call wrapper saves all of our volatile registers so that we don't have to. +call wrapper saves all of our volatile registers so that we don't have +to. -Since there are @HEAP_CHK@s buried at unfortunate places in the integer -primOps, this is just a wrapper. +Since there are @HEAP_CHK@s buried at unfortunate places in the +integer primOps, this is just a wrapper. \begin{code} - - genmacro HEAP_CHK args = - let [liveness,words,reenter] = map a2stix args +macroCode HEAP_CHK args + = let [liveness,words,reenter] = map amodeToStix args in - doHeapCheck liveness words reenter + heapCheck liveness words reenter \end{code} The @STK_CHK@ macro checks for enough space on the stack between @SpA@ @@ -125,12 +113,12 @@ enough space to continue. Not that @_StackOverflow@ doesn't return, so we don't have to @callWrapper@ it. \begin{code} - - genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] = +macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] + = {- Need to check to see if we are compiling with stack checks - getUniqLabelNCG `thenUs` \ ulbl -> + getUniqLabelNCG `thenUs` \ ulbl -> let words = StPrim IntNegOp - [StPrim IntAddOp [a2stix aWords, a2stix bWords]] + [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]] temp = StIndex PtrRep stgSpA words test = StPrim AddrGtOp [temp, stgSpB] cjmp = StCondJump ulbl test @@ -139,16 +127,16 @@ so we don't have to @callWrapper@ it. returnUs (\xs -> cjmp : stackOverflow : join : xs) -} returnUs id - \end{code} -@UPD_CAF@ involves changing the info pointer of the closure, adding an indirection, -and putting the new CAF on a linked list for the storage manager. +@UPD_CAF@ involves changing the info pointer of the closure, adding an +indirection, and putting the new CAF on a linked list for the storage +manager. \begin{code} - - genmacro UPD_CAF args = - let [cafptr,bhptr] = map a2stix args +macroCode UPD_CAF args + = let + [cafptr,bhptr] = map amodeToStix args w0 = StInd PtrRep cafptr w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1)) w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2)) @@ -157,8 +145,7 @@ and putting the new CAF on a linked list for the storage manager. a3 = StAssign PtrRep w2 bhptr a4 = StAssign PtrRep smCAFlist cafptr in - returnUs (\xs -> a1 : a2 : a3 : a4 : xs) - + returnUs (\xs -> a1 : a2 : a3 : a4 : xs) \end{code} @UPD_IND@ is complicated by the fact that we are supporting the @@ -166,10 +153,10 @@ Appel-style garbage collector by default. This means some extra work if we update an old generation object. \begin{code} - - genmacro UPD_IND args = - getUniqLabelNCG `thenUs` \ ulbl -> - let [updptr, heapptr] = map a2stix args +macroCode UPD_IND args + = getUniqLabelNCG `thenUs` \ ulbl -> + let + [updptr, heapptr] = map amodeToStix args test = StPrim AddrGtOp [updptr, smOldLim] cjmp = StCondJump ulbl test updRoots = StAssign PtrRep smOldMutables updptr @@ -180,26 +167,22 @@ if we update an old generation object. upd2 = StAssign PtrRep (StInd PtrRep (StIndex PtrRep updptr (StInt 2))) heapptr in - returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs) - + returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs) \end{code} @UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling. \begin{code} - - genmacro UPD_INPLACE_NOPTRS args = returnUs id - +macroCode 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 -if we update an old generation object. +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 `thenUs` \ ulbl -> +macroCode UPD_INPLACE_PTRS [liveness] + = getUniqLabelNCG `thenUs` \ ulbl -> let cjmp = StCondJump ulbl testOldLim testOldLim = StPrim AddrGtOp [stgNode, smOldLim] join = StLabel ulbl @@ -212,12 +195,11 @@ if we update an old generation object. updOldMutables = StAssign PtrRep smOldMutables stgNode updUpdReg = StAssign PtrRep stgNode hpBack2 in - genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0] - `thenUs` \ heap_chk -> - returnUs (\xs -> (cjmp : - heap_chk (updUpd0 : updUpd1 : updUpd2 : - updOldMutables : updUpdReg : join : xs))) - + macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0] + `thenUs` \ heap_chk -> + returnUs (\xs -> (cjmp : + heap_chk (updUpd0 : updUpd1 : updUpd2 : + updOldMutables : updUpdReg : join : xs))) \end{code} @UPD_BH_UPDATABLE@ is only used when running concurrent threads (in @@ -225,24 +207,22 @@ the sequential case, the GC takes care of this). However, we do need to handle @UPD_BH_SINGLE_ENTRY@ in all cases. \begin{code} +macroCode UPD_BH_UPDATABLE args = returnUs id - genmacro UPD_BH_UPDATABLE args = returnUs id - - genmacro UPD_BH_SINGLE_ENTRY [arg] = - let - update = StAssign PtrRep (StInd PtrRep (a2stix arg)) bh_info +macroCode UPD_BH_SINGLE_ENTRY [arg] + = let + update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info in - returnUs (\xs -> update : xs) - + returnUs (\xs -> update : xs) \end{code} Push a four word update frame on the stack and slide the Su[AB] registers to the current Sp[AB] locations. \begin{code} - - genmacro PUSH_STD_UPD_FRAME args = - let [bhptr, aWords, bWords] = map a2stix args +macroCode PUSH_STD_UPD_FRAME args + = let + [bhptr, aWords, bWords] = map amodeToStix args frame n = StInd PtrRep (StIndex PtrRep stgSpB (StPrim IntAddOp [bWords, StInt (toInteger (sTD_UF_SIZE - n))])) @@ -258,16 +238,15 @@ registers to the current Sp[AB] locations. updSuA = StAssign PtrRep stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords])) in - returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs) - + returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs) \end{code} Pop a standard update frame. \begin{code} - - genmacro POP_STD_UPD_FRAME args = - let frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n)))) +macroCode POP_STD_UPD_FRAME args + = let + frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n)))) grabRet = StAssign PtrRep stgRetReg (frame uF_RET) grabSuB = StAssign PtrRep stgSuB (frame uF_SUB) @@ -276,41 +255,38 @@ Pop a standard update frame. updSpB = StAssign PtrRep stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE)))) in - returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs) - + returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs) \end{code} The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' compilation. \begin{code} - genmacro SET_ARITY args = returnUs id - genmacro CHK_ARITY args = returnUs id +macroCode SET_ARITY args = returnUs id +macroCode 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 IntRep stgTagReg (a2stix tag) +macroCode SET_TAG [tag] + = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag) in - case stg_reg TagReg of - Always _ -> returnUs id - Save _ -> returnUs (\ xs -> set_tag : xs) + case stgReg 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 of StixOp. \begin{code} - -doHeapCheck - :: {- unused now: Target - -> -}StixTree -- liveness +heapCheck + :: StixTree -- liveness -> StixTree -- words needed -> StixTree -- always reenter node? (boolean) -> UniqSM StixTreeList -doHeapCheck {-target:unused now-} liveness words reenter = - getUniqLabelNCG `thenUs` \ ulbl -> +heapCheck liveness words reenter + = getUniqLabelNCG `thenUs` \ ulbl -> let newHp = StIndex PtrRep stgHp words assign = StAssign PtrRep stgHp newHp test = StPrim AddrLeOp [stgHp, stgHpLim] @@ -320,14 +296,12 @@ doHeapCheck {-target:unused now-} liveness words reenter = gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg] join = StLabel ulbl in - returnUs (\xs -> assign : cjmp : gc : join : xs) - + returnUs (\xs -> assign : cjmp : gc : join : xs) \end{code} Let's make sure that these CAFs are lifted out, shall we? \begin{code} - -- Some common labels bh_info, caf_info, ind_info :: StixTree @@ -342,34 +316,4 @@ updatePAP, stackOverflow :: StixTree updatePAP = StJump (sStLitLbl SLIT("UpdatePAP")) stackOverflow = StCall SLIT("StackOverflow") VoidRep [] - -\end{code} - -Storage manager nonsense. Note that the indices are dependent on -the definition of the smInfo structure in SMinterface.lh - -\begin{code} - -#include "../../includes/platform.h" - -#if alpha_TARGET_ARCH -#include "../../includes/alpha-dec-osf1.h" -#else -#if sunos4_TARGET_OS -#include "../../includes/sparc-sun-sunos4.h" -#else -#include "../../includes/sparc-sun-solaris2.h" -#endif -#endif - -storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree - -storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo") -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 PtrRep - (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE)) - \end{code} diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index e566c7b..d8e1bf6 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -1,190 +1,171 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \begin{code} #include "HsVersions.h" -module StixPrim ( - genPrimCode, amodeCode, amodeCode', +module StixPrim ( primCode, amodeToStix, amodeToStix' ) where - Target, CAddrMode, StixTree, PrimOp, UniqSupply - ) where +import Ubiq{-uitous-} +import NcgLoop -- paranoia checking only -IMPORT_Trace -- ToDo: rm debugging +import MachMisc +import MachRegs import AbsCSyn -import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), TyCon, - getPrimOpResultInfo, isCompareOp, showPrimOp - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) +import AbsCUtils ( getAmodeRep, mixedTypeLocn ) import CgCompInfo ( spARelToInt, spBRelToInt ) -import MachDesc -import Pretty -import PrimRep ( isFloatingRep ) -import CostCentre -import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) +import CostCentre ( noCostCentreAttached ) +import HeapOffs ( hpRelToInt, subOff ) +import Literal ( Literal(..) ) +import PrimOp ( PrimOp(..), isCompareOp, showPrimOp, + getPrimOpResultInfo, PrimOpResultInfo(..) + ) +import PrimRep ( PrimRep(..), isFloatingRep ) +import OrdList ( OrdList ) +import PprStyle ( PprStyle(..) ) +import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind ) import Stix -import StixMacro ( smStablePtrTable ) +import StixMacro ( heapCheck, smStablePtrTable ) import StixInteger {- everything -} -import UniqSupply -import Unpretty -import Util - +import UniqSupply ( returnUs, thenUs, UniqSM(..) ) +import Unpretty ( uppBeside, uppPStr, uppInt ) +import Util ( panic ) \end{code} -The main honcho here is genPrimCode, which handles the guts of COpStmts. +The main honcho here is primCode, which handles the guts of COpStmts. \begin{code} arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh) imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info") -genPrimCode - :: Target - -> [CAddrMode] -- results +primCode + :: [CAddrMode] -- results -> PrimOp -- op -> [CAddrMode] -- args -> UniqSM StixTreeList - \end{code} First, the dreaded @ccall@. We can't handle @casm@s. -Usually, this compiles to an assignment, but when the left-hand side is -empty, we just perform the call and ignore the result. +Usually, this compiles to an assignment, but when the left-hand side +is empty, we just perform the call and ignore the result. ToDo ADR: modify this to handle Malloc Ptrs. btw Why not let programmer use casm to provide assembly code instead of C code? ADR -\begin{code} --- hacking with Uncle Will: -#define target_STRICT target@(Target _ _ _ _ _ _ _ _) - -genPrimCode target_STRICT res op args - = genprim res op args - where - a2stix = amodeToStix target - a2stix' = amodeToStix' target - mut_hs = mutHS target - data_hs = dataHS target - heap_chkr = heapCheck target - size_of = sizeof target - fixed_hs = fixedHeaderSize 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 -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. +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} - -- NB: ordering of clauses somewhere driven by - -- the desire to getting sane patt-matching behavior - - genprim res@[ar1,sr1,dr1, ar2,sr2,dr2] - IntegerQuotRemOp - args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) - - genprim res@[ar1,sr1,dr1, ar2,sr2,dr2] - IntegerDivModOp - args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) - - genprim res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2) - genprim res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2) - genprim res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] = - gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2) - - genprim res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] = - gmpTake1Return1 target (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da) +-- NB: ordering of clauses somewhere driven by +-- the desire to getting sane patt-matching behavior + +primCode res@[ar1,sr1,dr1, ar2,sr2,dr2] + IntegerQuotRemOp + args@[liveness, aa1,sa1,da1, aa2,sa2,da2] + = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) + +primCode res@[ar1,sr1,dr1, ar2,sr2,dr2] + IntegerDivModOp + args@[liveness, aa1,sa1,da1, aa2,sa2,da2] + = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2) + +primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] + = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2) +primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] + = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2) +primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] + = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2) + +primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] + = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da) \end{code} -Since we are using the heap for intermediate @MP_INT@ structs, integer comparison -{\em does} require a heap check in the native code implementation. +Since we are using the heap for intermediate @MP_INT@ structs, integer +comparison {\em does} require a heap check in the native code +implementation. \begin{code} - genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] = - decodeFloatingKind FloatRep target (exponr,ar,sr,dr) (hp, arg) - - genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] = - decodeFloatingKind DoubleRep target (exponr,ar,sr,dr) (hp, arg) +primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] + = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg) - genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n] - = gmpInt2Integer target (ar,sr,dr) (hp, n) +primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] + = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg) - genprim res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str] - = gmpString2Integer target (ar,sr,dr) (liveness,str) +primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n] + = gmpInt2Integer (ar,sr,dr) (hp, n) - genprim [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2] - = gmpCompare target res (hp, aa1,sa1,da1, aa2,sa2,da2) +primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str] + = gmpString2Integer (ar,sr,dr) (liveness,str) - genprim [res] Integer2IntOp arg@[hp, aa,sa,da] - = gmpInteger2Int target res (hp, aa,sa,da) +primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2] + = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2) - genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] = - encodeFloatingKind FloatRep target res (hp, aa,sa,da, expon) +primCode [res] Integer2IntOp arg@[hp, aa,sa,da] + = gmpInteger2Int res (hp, aa,sa,da) - genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] = - encodeFloatingKind DoubleRep target res (hp, aa,sa,da, expon) +primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon] + = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon) - genprim [res] Int2AddrOp [arg] = - simpleCoercion AddrRep res arg +primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] + = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon) - genprim [res] Addr2IntOp [arg] = - simpleCoercion IntRep res arg +primCode [res] Int2AddrOp [arg] + = simpleCoercion AddrRep res arg - genprim [res] Int2WordOp [arg] = - simpleCoercion IntRep{-WordRep?-} res arg +primCode [res] Addr2IntOp [arg] + = simpleCoercion IntRep res arg - genprim [res] Word2IntOp [arg] = - simpleCoercion IntRep res arg +primCode [res] Int2WordOp [arg] + = simpleCoercion IntRep{-WordRep?-} res arg +primCode [res] Word2IntOp [arg] + = simpleCoercion IntRep res arg \end{code} -The @ErrorIO@ primitive is actually a bit weird...assign a new value to the root -closure, flush stdout and stderr, and jump to the @ErrorIO_innards@. +The @ErrorIO@ primitive is actually a bit weird...assign a new value +to the root closure, flush stdout and stderr, and jump to the +@ErrorIO_innards@. \begin{code} - - genprim [] ErrorIOPrimOp [rhs] = - let changeTop = StAssign PtrRep topClosure (a2stix rhs) +primCode [] ErrorIOPrimOp [rhs] + = let + changeTop = StAssign PtrRep topClosure (amodeToStix rhs) in - returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs) - + returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs) \end{code} @newArray#@ ops allocate heap space. \begin{code} - genprim [res] NewArrayOp args = - let [liveness, n, initial] = map a2stix args - result = a2stix res - space = StPrim IntAddOp [n, mut_hs] +primCode [res] NewArrayOp args + = let + [liveness, n, initial] = map amodeToStix args + result = amodeToStix res + space = StPrim IntAddOp [n, mutHS] loc = StIndex PtrRep stgHp (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]]) assign = StAssign PtrRep result loc initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial] in - heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk -> - - returnUs (heap_chk . (\xs -> assign : initialise : xs)) - - genprim [res] (NewByteArrayOp pk) args = - let [liveness, count] = map a2stix args - result = a2stix res - n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))] - 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]] + heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> + + returnUs (heap_chk . (\xs -> assign : initialise : xs)) + +primCode [res] (NewByteArrayOp pk) args + = let + [liveness, count] = map amodeToStix args + result = amodeToStix res + n = StPrim IntMulOp [count, StInt (sizeOf pk)] + slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)] + words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)] + space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]] loc = StIndex PtrRep stgHp (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]]) assign = StAssign PtrRep result loc @@ -192,117 +173,121 @@ closure, flush stdout and stderr, and jump to the @ErrorIO_innards@. init2 = StAssign IntRep (StInd IntRep (StIndex IntRep loc - (StInt (toInteger fixed_hs)))) + (StInt (toInteger fixedHdrSizeInWords)))) (StPrim IntAddOp [words, - StInt (toInteger (var_hs (DataRep 0)))]) + StInt (toInteger (varHdrSizeInWords (DataRep 0)))]) in - heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk -> + heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> - returnUs (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 IntRep (a2stix res) compare +primCode [res] SameMutableArrayOp args + = let + compare = StPrim AddrEqOp (map amodeToStix args) + assign = StAssign IntRep (amodeToStix res) compare in - returnUs (\xs -> assign : xs) - - genprim res@[_] SameMutableByteArrayOp args = - genprim res SameMutableArrayOp args + returnUs (\xs -> assign : xs) +primCode res@[_] SameMutableByteArrayOp args + = primCode res SameMutableArrayOp args \end{code} -Freezing an array of pointers is a double assignment. We fix the header of -the ``new'' closure because the lhs is probably a better addressing mode for -the indirection (most likely, it's a VanillaReg). +Freezing an array of pointers is a double assignment. We fix the +header of the ``new'' closure because the lhs is probably a better +addressing mode for the indirection (most likely, it's a VanillaReg). \begin{code} - genprim [lhs] UnsafeFreezeArrayOp [rhs] = - let lhs' = a2stix lhs - rhs' = a2stix rhs +primCode [lhs] UnsafeFreezeArrayOp [rhs] + = let + lhs' = amodeToStix lhs + rhs' = amodeToStix rhs header = StInd PtrRep lhs' assign = StAssign PtrRep lhs' rhs' freeze = StAssign PtrRep header imMutArrayOfPtrs_info in - returnUs (\xs -> assign : freeze : xs) - - genprim [lhs] UnsafeFreezeByteArrayOp [rhs] = - simpleCoercion PtrRep lhs rhs + returnUs (\xs -> assign : freeze : xs) +primCode [lhs] UnsafeFreezeByteArrayOp [rhs] + = simpleCoercion PtrRep lhs rhs \end{code} Most other array primitives translate to simple indexing. \begin{code} - genprim lhs@[_] IndexArrayOp args = - genprim lhs ReadArrayOp args +primCode lhs@[_] IndexArrayOp args + = primCode lhs ReadArrayOp args - genprim [lhs] ReadArrayOp [obj, ix] = - let lhs' = a2stix lhs - obj' = a2stix obj - ix' = a2stix ix - base = StIndex IntRep obj' mut_hs +primCode [lhs] ReadArrayOp [obj, ix] + = let + lhs' = amodeToStix lhs + obj' = amodeToStix obj + ix' = amodeToStix ix + base = StIndex IntRep obj' mutHS assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix')) in - returnUs (\xs -> assign : xs) - - genprim [lhs] WriteArrayOp [obj, ix, v] = - let obj' = a2stix obj - ix' = a2stix ix - v' = a2stix v - base = StIndex IntRep obj' mut_hs + returnUs (\xs -> assign : xs) + +primCode [lhs] WriteArrayOp [obj, ix, v] + = let + obj' = amodeToStix obj + ix' = amodeToStix ix + v' = amodeToStix v + base = StIndex IntRep obj' mutHS assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v' in - returnUs (\xs -> assign : xs) + returnUs (\xs -> assign : xs) - genprim lhs@[_] (IndexByteArrayOp pk) args = - genprim lhs (ReadByteArrayOp pk) args +primCode lhs@[_] (IndexByteArrayOp pk) args + = primCode lhs (ReadByteArrayOp pk) args -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09) - genprim [lhs] (ReadByteArrayOp pk) [obj, ix] = - let lhs' = a2stix lhs - obj' = a2stix obj - ix' = a2stix ix - base = StIndex IntRep obj' data_hs +primCode [lhs] (ReadByteArrayOp pk) [obj, ix] + = let + lhs' = amodeToStix lhs + obj' = amodeToStix obj + ix' = amodeToStix ix + base = StIndex IntRep obj' dataHS assign = StAssign pk lhs' (StInd pk (StIndex pk base ix')) in - returnUs (\xs -> assign : xs) + returnUs (\xs -> assign : xs) - genprim [lhs] (IndexOffAddrOp pk) [obj, ix] = - let lhs' = a2stix lhs - obj' = a2stix obj - ix' = a2stix ix +primCode [lhs] (IndexOffAddrOp pk) [obj, ix] + = let + lhs' = amodeToStix lhs + obj' = amodeToStix obj + ix' = amodeToStix ix assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix')) in - returnUs (\xs -> assign : xs) - - genprim [] (WriteByteArrayOp pk) [obj, ix, v] = - let obj' = a2stix obj - ix' = a2stix ix - v' = a2stix v - base = StIndex IntRep obj' data_hs + returnUs (\xs -> assign : xs) + +primCode [] (WriteByteArrayOp pk) [obj, ix, v] + = let + obj' = amodeToStix obj + ix' = amodeToStix ix + v' = amodeToStix v + base = StIndex IntRep obj' dataHS assign = StAssign pk (StInd pk (StIndex pk base ix')) v' in - returnUs (\xs -> assign : xs) + returnUs (\xs -> assign : xs) \end{code} Stable pointer operations. First the easy one. - \begin{code} - genprim [lhs] DeRefStablePtrOp [sp] = - let lhs' = a2stix lhs +primCode [lhs] DeRefStablePtrOp [sp] + = let + lhs' = amodeToStix lhs pk = getAmodeRep lhs - sp' = a2stix sp + sp' = amodeToStix sp call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable] assign = StAssign pk lhs' call in - returnUs (\xs -> assign : xs) - + returnUs (\xs -> assign : xs) \end{code} Now the hard one. For comparison, here's the code from StgMacros: @@ -349,8 +334,8 @@ Notes for ADR: --JSM \begin{pseudocode} - genprim [lhs] MakeStablePtrOp args = - let +primCode [lhs] MakeStablePtrOp args + = let -- some useful abbreviations (I'm sure these must exist already) add = trPrim . IntAddOp sub = trPrim . IntSubOp @@ -359,7 +344,7 @@ Notes for ADR: 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 + dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep 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]] @@ -380,8 +365,8 @@ Notes for ADR: ] -- now to get down to business - lhs' = amodeCode sty md lhs - [liveness, unstable] = map (amodeCode sty md) args + lhs' = amodeCode lhs + [liveness, unstable] = map amodeCode args spt = smStablePtrTable @@ -408,81 +393,81 @@ Notes for ADR: \end{pseudocode} \begin{code} - genprim res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp" - - 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 - [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs) - [lhs] -> - let lhs' = a2stix lhs - pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep - call = StAssign pk lhs' (StCall fn pk args) - in - returnUs (\xs -> call : xs) - where - args = map amodeCodeForCCall rhs - amodeCodeForCCall x = - let base = a2stix' x - in - 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 +primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp" + +primCode 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 + [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs) + [lhs] -> + let lhs' = amodeToStix lhs + pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep + call = StAssign pk lhs' (StCall fn pk args) + in + returnUs (\xs -> call : xs) + where + args = map amodeCodeForCCall rhs + amodeCodeForCCall x = + let base = amodeToStix' x + in + case getAmodeRep x of + ArrayRep -> StIndex PtrRep base mutHS + ByteArrayRep -> StIndex IntRep base dataHS + MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!" + _ -> base \end{code} Now the more mundane operations. \begin{code} - genprim lhs op rhs = - let lhs' = map a2stix lhs - rhs' = map a2stix' rhs +primCode lhs op rhs + = let + lhs' = map amodeToStix lhs + rhs' = map amodeToStix' rhs in - returnUs (\ xs -> simplePrim lhs' op rhs' : xs) - - {- - simpleCoercion - :: Target - -> PrimRep - -> [CAddrMode] - -> [CAddrMode] + returnUs (\ xs -> simplePrim lhs' op rhs' : xs) +\end{code} + +\begin{code} +simpleCoercion + :: PrimRep + -> CAddrMode + -> CAddrMode -> UniqSM StixTreeList - -} - simpleCoercion pk lhs rhs = - returnUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs) +simpleCoercion pk lhs rhs + = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix 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 -at the level of the specific code generator. +Here we try to rewrite primitives into a form the code generator can +understand. Any primitives not handled here must be handled at the +level of the specific code generator. \begin{code} - {- - simplePrim - :: Target - -> [StixTree] +simplePrim + :: [StixTree] -> PrimOp -> [StixTree] -> StixTree - -} \end{code} Now look for something more conventional. \begin{code} - - simplePrim [lhs] op rest = StAssign pk lhs (StPrim op rest) - where pk = if isCompareOp op then IntRep - else case getPrimOpResultInfo op of - ReturnsPrim pk -> pk - _ -> simplePrim_error op - - simplePrim _ op _ = simplePrim_error op - - simplePrim_error op +simplePrim [lhs] op rest + = StAssign pk lhs (StPrim op rest) + where + pk = if isCompareOp op then + IntRep + else + case getPrimOpResultInfo op of + ReturnsPrim pk -> pk + _ -> simplePrim_error op + +simplePrim _ op _ = simplePrim_error op + +simplePrim_error op = error ("ERROR: primitive operation `"++showPrimOp PprDebug op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n") \end{code} @@ -490,120 +475,109 @@ Now look for something more conventional. Here we generate the Stix code for CAddrModes. -When a character is fetched from a mixed type location, we have to -do an extra cast. This is reflected in amodeCode', which is for rhs +When a character is fetched from a mixed type location, we have to do +an extra cast. This is reflected in amodeCode', which is for rhs amodes that might possibly need the extra cast. \begin{code} +amodeToStix, amodeToStix' :: CAddrMode -> StixTree -amodeCode, amodeCode' - :: Target - -> CAddrMode - -> StixTree - -amodeCode'{-'-} target_STRICT am@(CVal rr CharRep) - | mixedTypeLocn am = StPrim ChrOp [amodeToStix target am] - | otherwise = amodeToStix target am - -amodeCode' target am = amodeToStix target am +amodeToStix'{-'-} am@(CVal rr CharRep) + | mixedTypeLocn am = StPrim ChrOp [amodeToStix am] + | otherwise = amodeToStix am -amodeCode target_STRICT am - = acode am - where - -- grab "target" things: - hp_rel = hpRel target - char_like = charLikeClosureSize target - int_like = intLikeClosureSize target - a2stix = amodeToStix target +amodeToStix' am = amodeToStix am - -- real code: ---------------------------------- - acode am@(CVal rr CharRep) | mixedTypeLocn am = - StInd IntRep (acode (CAddr rr)) +----------- +amodeToStix am@(CVal rr CharRep) + | mixedTypeLocn am + = StInd IntRep (amodeToStix (CAddr rr)) - acode (CVal rr pk) = StInd pk (acode (CAddr rr)) +amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr)) - acode (CAddr (SpARel spA off)) = - StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off))) +amodeToStix (CAddr (SpARel spA off)) + = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off))) - acode (CAddr (SpBRel spB off)) = - StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off))) +amodeToStix (CAddr (SpBRel spB off)) + = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off))) - acode (CAddr (HpRel hp off)) = - StIndex IntRep stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off))))) +amodeToStix (CAddr (HpRel hp off)) + = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off))))) - acode (CAddr (NodeRel off)) = - StIndex IntRep stgNode (StInt (toInteger (hp_rel off))) +amodeToStix (CAddr (NodeRel off)) + = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off))) - acode (CReg magic) = StReg (StixMagicId magic) - acode (CTemp uniq pk) = StReg (StixTemp uniq pk) +amodeToStix (CReg magic) = StReg (StixMagicId magic) +amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk) - acode (CLbl lbl _) = StCLbl lbl +amodeToStix (CLbl lbl _) = StCLbl lbl +amodeToStix (CUnVecLbl dir _) = StCLbl dir - acode (CUnVecLbl dir _) = StCLbl dir - - acode (CTableEntry base off pk) = - StInd pk (StIndex pk (acode base) (acode off)) +amodeToStix (CTableEntry base off pk) + = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off)) -- For CharLike and IntLike, we attempt some trivial constant-folding here. - acode (CCharLike (CLit (MachChar c))) = - StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) - where off = char_like * ord c +amodeToStix (CCharLike (CLit (MachChar c))) + = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) + where + off = charLikeSize * ord c - acode (CCharLike x) = - StPrim IntAddOp [charLike, off] - where off = StPrim IntMulOp [acode x, - StInt (toInteger (char_like))] +amodeToStix (CCharLike x) + = StPrim IntAddOp [charLike, off] + where + off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)] - acode (CIntLike (CLit (MachInt i _))) = - StPrim IntAddOp [intLikePtr, StInt off] - where off = toInteger int_like * i +amodeToStix (CIntLike (CLit (MachInt i _))) + = StPrim IntAddOp [intLikePtr, StInt off] + where + off = toInteger intLikeSize * i - acode (CIntLike x) = - StPrim IntAddOp [intLikePtr, off] - where off = StPrim IntMulOp [acode x, - StInt (toInteger int_like)] +amodeToStix (CIntLike x) + = StPrim IntAddOp [intLikePtr, off] + where + off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)] -- A CString is just a (CLit . MachStr) - acode (CString s) = StString s - - acode (CLit core) = case core of - (MachChar c) -> StInt (toInteger (ord c)) - (MachStr s) -> StString s - (MachAddr a) -> StInt a - (MachInt i _) -> StInt i - (MachLitLit s _) -> StLitLit s - (MachFloat d) -> StDouble d - (MachDouble d) -> StDouble d - _ -> panic "amodeCode:core literal" +amodeToStix (CString s) = StString s + +amodeToStix (CLit core) + = case core of + MachChar c -> StInt (toInteger (ord c)) + MachStr s -> StString s + MachAddr a -> StInt a + MachInt i _ -> StInt i + MachLitLit s _ -> StLitLit s + MachFloat d -> StDouble d + MachDouble d -> StDouble d + _ -> panic "amodeToStix:core literal" -- A CLitLit is just a (CLit . MachLitLit) - acode (CLitLit s _) = StLitLit s +amodeToStix (CLitLit s _) = StLitLit s -- COffsets are in words, not bytes! - acode (COffset off) = StInt (toInteger (hp_rel off)) - - acode (CMacroExpr _ macro [arg]) = - case macro of - INFO_PTR -> StInd PtrRep (a2stix arg) - ENTRY_CODE -> a2stix arg - INFO_TAG -> tag - EVAL_TAG -> StPrim IntGeOp [tag, StInt 0] +amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off)) + +amodeToStix (CMacroExpr _ macro [arg]) + = case macro of + INFO_PTR -> StInd PtrRep (amodeToStix arg) + ENTRY_CODE -> amodeToStix arg + INFO_TAG -> tag + EVAL_TAG -> StPrim IntGeOp [tag, StInt 0] where - tag = StInd IntRep (StIndex IntRep (a2stix arg) (StInt (-2))) - -- That ``-2'' really bothers me. (JSM) + tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2))) + -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP]) - acode (CCostCentre cc print_as_string) - = if noCostCentreAttached cc - then StComment SLIT("") -- sigh - else panic "amodeCode:CCostCentre" +amodeToStix (CCostCentre cc print_as_string) + = if noCostCentreAttached cc + then StComment SLIT("") -- sigh + else panic "amodeToStix:CCostCentre" \end{code} -Sizes of the CharLike and IntLike closures that are arranged as arrays in the -data segment. (These are in bytes.) +Sizes of the CharLike and IntLike closures that are arranged as arrays +in the data segment. (These are in bytes.) \begin{code} - -- The INTLIKE base pointer intLikePtr :: StixTree @@ -624,6 +598,5 @@ 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} diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs index 6a4066b..3600897 100644 --- a/ghc/compiler/parser/UgenAll.lhs +++ b/ghc/compiler/parser/UgenAll.lhs @@ -13,7 +13,6 @@ module UgenAll ( U_constr.. , U_coresyn.. , U_entidt.. , - U_finfot.. , U_hpragma.. , U_list.. , U_literal.. , @@ -35,7 +34,6 @@ import U_binding import U_constr import U_coresyn import U_entidt -import U_finfot import U_hpragma import U_list import U_literal diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex index 5cfe16d..892d2f9 100644 --- a/ghc/compiler/parser/hslexer.flex +++ b/ghc/compiler/parser/hslexer.flex @@ -50,13 +50,13 @@ static unsigned char CharTable[NCHARS] = { /* 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, /* ( */ +/* '(' */ _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, /* [ */ +/* '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, diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index a3e9917..0743c55 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -1662,6 +1662,7 @@ aexp : qvar { $$ = mkident($1); } | gcon { $$ = mkident($1); } | lit_constant { $$ = mklit($1); } | OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */ + | qcon OCURLY CCURLY { $$ = mkrecord($1,Lnil); } | 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) diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 18d0e56..e60b8d6 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -101,7 +101,7 @@ import FiniteMap import Id ( mkTupleCon, GenId{-instances-} ) import Name ( Name(..) ) import NameTypes ( mkPreludeCoreName, FullName, ShortName ) -import TyCon ( getTyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon{-instances-} ) +import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon{-instances-} ) import Type import Unique -- *Key stuff import Util ( nOfThem, panic ) @@ -401,5 +401,5 @@ 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 ] + [ (getOccurrenceName con, WiredInVal con) | con <- tyConDataCons tycon ] \end{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 457d11b..b4845f7 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -10,6 +10,7 @@ module PrelVals where import Ubiq import IdLoop ( UnfoldingGuidance(..) ) +import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals ) import PrelLoop -- friends: @@ -29,13 +30,13 @@ import SpecEnv ( SpecEnv(..), nullSpecEnv ) import TyVar ( alphaTyVar, betaTyVar ) import Unique -- lots of *Keys import Util ( panic ) +\end{code} + --- only used herein: -mkPreludeId = panic "PrelVals:Id.mkPreludeId" -mkSpecId = panic "PrelVals:Id.mkSpecId" -mkTemplateLocals = panic "PrelVals:Id.mkTemplateLocals" -specialiseTy = panic "PrelVals:specialiseTy" + +\begin{code} +-- only used herein: pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id pcMiscPrelId key mod name ty info diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 5dd0ccb..0fd25b7 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -11,22 +11,21 @@ module PrimOp ( tagOf_PrimOp, -- ToDo: rm primOp_str, -- sigh primOpType, isCompareOp, + commutableOp, PrimOpResultInfo(..), getPrimOpResultInfo, ---MOVE: primOpCanTriggerGC, primOpNeedsWrapper, ---MOVE: primOpOkForSpeculation, primOpIsCheap, ---MOVE: fragilePrimOp, ---MOVE: HeapRequirement(..), primOpHeapReq, + primOpCanTriggerGC, primOpNeedsWrapper, + primOpOkForSpeculation, primOpIsCheap, + fragilePrimOp, + HeapRequirement(..), primOpHeapReq, -- export for the Native Code Generator primOpInfo, -- needed for primOpNameInfo PrimOpInfo(..), pprPrimOp, showPrimOp - - -- and to make the interface self-sufficient.... ) where import Ubiq{-uitous-} @@ -37,19 +36,19 @@ import TysWiredIn import CStrings ( identToC ) import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) +import HeapOffs ( addOff, intOff, totHdrSize ) import NameTypes ( mkPreludeCoreName, FullName, ShortName ) import PprStyle ( codeStyle ) +import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} ) import Pretty import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) import TyCon ( TyCon{-instances-} ) import Type ( getAppDataTyCon, maybeAppDataTyCon, - mkForAllTys, mkFunTys, applyTyCon ) -import TyVar ( alphaTyVar, betaTyVar ) + mkForAllTys, mkFunTys, applyTyCon, typePrimRep + ) +import TyVar ( alphaTyVar, betaTyVar, GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instance Eq-} ) import Util ( panic#, assoc, panic{-ToDo:rm-} ) - -glueTyArgs = panic "PrimOp:glueTyArgs" -pprParendType = panic "PrimOp:pprParendType" -primRepFromType = panic "PrimOp:primRepFromType" \end{code} %************************************************************************ @@ -1305,7 +1304,6 @@ unfortunate few, some unknown amount of heap is required (these are the ops which can trigger GC). \begin{code} -{- MOVE: data HeapRequirement = NoHeapRequired | FixedHeapRequired HeapOffset @@ -1395,7 +1393,6 @@ primOpHeapReq ParLocalOp = trace "primOpHeapReq:ParLocalOp:verify!" ( #endif {-GRAN-} primOpHeapReq other_op = NoHeapRequired --} \end{code} Primops which can trigger GC have to be called carefully. @@ -1403,9 +1400,8 @@ In particular, their arguments are guaranteed to be in registers, and a liveness mask tells which regs are live. \begin{code} -{- MOVE: -primOpCanTriggerGC op = - case op of +primOpCanTriggerGC op + = case op of TakeMVarOp -> True ReadIVarOp -> True DelayOp -> True @@ -1414,7 +1410,6 @@ primOpCanTriggerGC op = case primOpHeapReq op of VariableHeapRequired -> True _ -> False --} \end{code} Sometimes we may choose to execute a PrimOp even though it isn't @@ -1429,7 +1424,6 @@ There should be no worries about side effects; that's all taken care of by data dependencies. \begin{code} -{- MOVE: primOpOkForSpeculation :: PrimOp -> Bool -- Int. @@ -1470,24 +1464,20 @@ primOpOkForSpeculation ParLocalOp = False -- Could be expensive! -- 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 @@ -1504,14 +1494,12 @@ fragilePrimOp NoFollowOp = trace "fragilePrimOp:NoFollowOp" True -- Possibly no #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 @@ -1574,7 +1562,6 @@ primOpNeedsWrapper DelayOp = True primOpNeedsWrapper WaitOp = True primOpNeedsWrapper other_op = False --} \end{code} \begin{code} @@ -1601,10 +1588,10 @@ primOpType op Coerce str ty1 ty2 -> mkFunTys [ty1] ty2 PrimResult str tyvars arg_tys prim_tycon kind res_tys -> - mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys)) + mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)) AlgResult str tyvars arg_tys tycon res_tys -> - mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys)) + mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)) \end{code} \begin{code} @@ -1619,10 +1606,10 @@ getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Dyadic _ ty -> ReturnsPrim (primRepFromType ty) - Monadic _ ty -> ReturnsPrim (primRepFromType ty) + Dyadic _ ty -> ReturnsPrim (typePrimRep ty) + Monadic _ ty -> ReturnsPrim (typePrimRep ty) Compare _ ty -> ReturnsAlg boolTyCon - Coerce _ _ ty -> ReturnsPrim (primRepFromType ty) + Coerce _ _ ty -> ReturnsPrim (typePrimRep ty) PrimResult _ _ _ _ kind _ -> ReturnsPrim kind AlgResult _ _ _ tycon _ -> ReturnsAlg tycon @@ -1634,6 +1621,33 @@ isCompareOp op _ -> False \end{code} +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 IntMulOp = True +commutableOp AndOp = True +commutableOp OrOp = True +commutableOp IntEqOp = True +commutableOp IntNeOp = True +commutableOp IntegerAddOp = True +commutableOp IntegerMulOp = True +commutableOp FloatAddOp = True +commutableOp FloatMulOp = True +commutableOp FloatEqOp = True +commutableOp FloatNeOp = True +commutableOp DoubleAddOp = True +commutableOp DoubleMulOp = True +commutableOp DoubleEqOp = True +commutableOp DoubleNeOp = True +commutableOp _ = False +\end{code} + Utils: \begin{code} dyadic_fun_ty ty = mkFunTys [ty, ty] ty @@ -1662,8 +1676,8 @@ pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) pp_tys = ppBesides [ppStr " { [", - ppIntersperse pp'SP{-'-} (map (pprParendType sty) arg_tys), - ppRbrack, ppSP, pprParendType sty res_ty, ppStr " })"] + ppIntersperse pp'SP{-'-} (map (pprParendGenType sty) arg_tys), + ppRbrack, ppSP, pprParendGenType sty res_ty, ppStr " })"] in ppBesides [ppStr before, ppPStr fun, after, pp_tys] diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index c16c6b8..092a9f4 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -17,8 +17,7 @@ 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 TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) ) import TyVar ( GenTyVar(..), alphaTyVars ) import Type ( applyTyCon, mkTyVarTys ) import Usage ( usageOmega ) @@ -119,7 +118,6 @@ realWorldTyCon [{-no context-}] [{-no data cons!-}] -- we tell you *nothing* about this guy [{-no derivings-}] - ConsInvisible DataType where full_name = mkPreludeCoreName pRELUDE_BUILTIN SLIT("_RealWorld") diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 514682d..977758f 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -100,7 +100,8 @@ import NameTypes ( mkPreludeCoreName, mkShortName ) import Kind ( mkBoxedTypeKind, mkArrowKind ) import SrcLoc ( mkBuiltinSrcLoc ) import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon, - ConsVisible(..), NewOrData(..), TyCon ) + NewOrData(..), TyCon + ) import Type ( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy, mkFunTys, maybeAppDataTyCon, GenType(..), ThetaType(..), TauType(..) ) @@ -117,7 +118,7 @@ pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> [I pcDataTyCon key mod name tyvars cons = mkDataTyCon key tycon_kind full_name tyvars [{-no context-}] cons [{-no derivings-}] - ConsVisible DataType + DataType where full_name = mkPreludeCoreName mod name tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind tyvars diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 58ca3cb..9702645 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[SCCfinal]{Modify and collect code generation for final STG program} @@ -27,35 +27,35 @@ This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg. module SCCfinal ( stgMassageForProfiling ) where -import Pretty -- ToDo: rm (debugging only) +import Ubiq{-uitous-} -import Type ( isFunType, getTauType ) -import CmdLineOpts -import CostCentre -import Id ( mkSysLocal, idType ) -import SrcLoc ( mkUnknownSrcLoc ) import StgSyn -import UniqSupply -import UniqSet ( emptyUniqSet - IF_ATTACK_PRAGMAS(COMMA emptyUFM) + +import CmdLineOpts ( opt_AutoSccsOnIndividualCafs, + opt_CompilingPrelude ) -import Util +import CostCentre -- lots of things +import Id ( idType, mkSysLocal, emptyIdSet ) +import Maybes ( maybeToBool ) +import SrcLoc ( mkUnknownSrcLoc ) +import Type ( splitSigmaTy, getFunTy_maybe ) +import UniqSupply ( getUnique, splitUniqSupply ) +import Util ( removeDups, assertPanic ) infixr 9 `thenMM`, `thenMM_` \end{code} \begin{code} -type CollectedCCs = ([CostCentre], -- locally defined ones - [CostCentre]) -- ones needing "extern" decls +type CollectedCCs = ([CostCentre], -- locally defined ones + [CostCentre]) -- ones needing "extern" decls stgMassageForProfiling - :: FAST_STRING -> FAST_STRING -- module name, group name - -> UniqSupply -- unique supply - -> (GlobalSwitch -> Bool) -- command-line opts checker - -> [StgBinding] -- input + :: FAST_STRING -> FAST_STRING -- module name, group name + -> UniqSupply -- unique supply + -> [StgBinding] -- input -> (CollectedCCs, [StgBinding]) -stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds +stgMassageForProfiling mod_name grp_name us stg_binds = let ((local_ccs, extern_ccs), stg_binds2) @@ -71,8 +71,8 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds in ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2) where - do_auto_sccs_on_cafs = sw_chkr AutoSccsOnIndividualCafs -- only use! - doing_prelude = sw_chkr CompilingPrelude + do_auto_sccs_on_cafs = opt_AutoSccsOnIndividualCafs -- only use! + doing_prelude = opt_CompilingPrelude all_cafs_cc = if doing_prelude then preludeCafsCostCentre @@ -298,7 +298,9 @@ boxHigherOrderArgs almost_expr args live_vars in returnMM ( (new_var, old_var) : bindings, StgVarArg new_var ) where - is_fun_type ty = isFunType (getTauType ty) + is_fun_type ty + = case (splitSigmaTy ty) of { (_, _, tau_ty) -> + maybeToBool (getFunTy_maybe tau_ty) } --------------- mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr @@ -313,7 +315,7 @@ boxHigherOrderArgs almost_expr args live_vars in StgLet (StgNonRec new_var rhs) body where - bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs" + bOGUS_LVs = emptyIdSet -- easier to print than: panic "mk_stg_let: LVs" \end{code} %************************************************************************ diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 6043f72..733dd7f 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -31,7 +31,7 @@ import MainMonad ( thenMn, MainIO(..) ) import PprStyle ( PprStyle(..) ) import Pretty import ProtoName ( isConopPN, ProtoName(..) ) -import Util ( nOfThem, panic ) +import Util ( nOfThem, pprError, panic ) \end{code} %************************************************************************ @@ -327,7 +327,7 @@ wlkExpr expr U_record con rbinds -> -- record construction wlkQid con `thenUgn` \ rcon -> wlkList rdRbind rbinds `thenUgn` \ recbinds -> - returnUgn (RecordCon rcon recbinds) + returnUgn (RecordCon (HsVar rcon) recbinds) U_rupdate updexp updbinds -> -- record update wlkExpr updexp `thenUgn` \ aexp -> @@ -352,7 +352,11 @@ rdRbind pt = rdU_tree pt `thenUgn` \ (U_rbind var exp) -> wlkQid var `thenUgn` \ rvar -> wlkMaybe rdExpr exp `thenUgn` \ expr_maybe -> - returnUgn (rvar, expr_maybe) + returnUgn ( + case expr_maybe of + Nothing -> (rvar, HsVar rvar, True{-pun-}) + Just re -> (rvar, re, False) + ) \end{code} Patterns: just bear in mind that lists of patterns are represented as @@ -406,9 +410,8 @@ wlkPat pat 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))])) + pprError "ERROR: an illegal `application' of a pattern to another one:" + (ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats))) in returnUgn (ConPatIn n arg_pats) where @@ -444,7 +447,11 @@ wlkPat pat = rdU_tree pt `thenUgn` \ (U_rbind var pat) -> wlkQid var `thenUgn` \ rvar -> wlkMaybe rdPat pat `thenUgn` \ pat_maybe -> - returnUgn (rvar, pat_maybe) + returnUgn ( + case pat_maybe of + Nothing -> (rvar, VarPatIn rvar, True{-pun-}) + Just rp -> (rvar, rp, False) + ) \end{code} \begin{code} @@ -748,7 +755,7 @@ mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName) mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname) mk_class_assertion other - = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n") + = pprError "ERROR: malformed type context: " (ppr PprForUser other) -- regrettably, the parser does let some junk past -- e.g., f :: Num {-nothing-} => a -> ... \end{code} @@ -784,14 +791,14 @@ 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) + returnUgn (RecConDecl con fields_lists src_loc) where - rd_field :: ParseTree -> UgnM [(ProtoName, BangType ProtoName)] + 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 ] + returnUgn (vars, ty) ----------------- rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty diff --git a/ghc/compiler/rename/RnBinds4.lhs b/ghc/compiler/rename/RnBinds4.lhs index 418c626..57303d8 100644 --- a/ghc/compiler/rename/RnBinds4.lhs +++ b/ghc/compiler/rename/RnBinds4.lhs @@ -15,8 +15,6 @@ module RnBinds4 ( rnTopBinds, rnMethodBinds, rnBinds, FreeVars(..), DefinedVars(..) - - -- and to make the interface self-sufficient... ) where import Ubiq{-uitous-} @@ -37,9 +35,9 @@ 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, +import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, unionUniqSets, unionManyUniqSets, - elementOfUniqSet, + elementOfUniqSet, addOneToUniqSet, uniqSetToList, UniqSet(..) ) @@ -368,7 +366,7 @@ flattenMonoBinds uniq sigs (FunMonoBind name matches locn) returnRn4 ( uniq + 1, [(uniq, - singletonUniqSet name', + unitUniqSet name', fvs `unionUniqSets` sigs_fvs, FunMonoBind name' new_matches locn, sigs_for_me @@ -391,7 +389,7 @@ sig_for_here want_me acc other_wise = acc -- acct in the dependency analysis (or we get an -- unexpected out-of-scope error)! WDP 95/07 -sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` singletonUniqSet blah +sig_fv (SpecSig _ _ (Just blah) _) acc = addOneToUniqSet acc blah sig_fv _ acc = acc \end{code} diff --git a/ghc/compiler/rename/RnExpr4.lhs b/ghc/compiler/rename/RnExpr4.lhs index 21f5346..99f0b75 100644 --- a/ghc/compiler/rename/RnExpr4.lhs +++ b/ghc/compiler/rename/RnExpr4.lhs @@ -30,7 +30,7 @@ import RnMonad4 import Name ( Name(..) ) import NameTypes ( FullName{-instances-} ) import Outputable ( isConop ) -import UniqSet ( emptyUniqSet, singletonUniqSet, +import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, UniqSet(..) ) @@ -193,11 +193,11 @@ 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@(Short uniq sname) = unitUniqSet n fv_set n@(ValName uniq fname) | isLocallyDefined fname && not (isConop (getOccurrenceName fname)) - = singletonUniqSet n + = unitUniqSet n fv_set other = emptyUniqSet rnExpr (HsLit lit) = returnRn4 (HsLit lit, emptyUniqSet) diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index b141a30..278fc65 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -32,6 +32,7 @@ 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 RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat type RenamedImportedInterface = ImportedInterface Fake Fake Name RenamedPat type RenamedInstDecl = InstDecl Fake Fake Name RenamedPat type RenamedInstancePragmas = InstancePragmas Name diff --git a/ghc/compiler/rename/RnPass1.lhs b/ghc/compiler/rename/RnPass1.lhs index 53f4bb6..bd76c69 100644 --- a/ghc/compiler/rename/RnPass1.lhs +++ b/ghc/compiler/rename/RnPass1.lhs @@ -652,7 +652,7 @@ doIfaceTyDecls1 sifun full_tc_nf ty_decls 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_field (vars, ty) = (map cf_nf vars, do_bang tc_nf ty) -------------------------------------------- do_bang tc_nf (Banged ty) = Banged (doIfaceMonoType1 tc_nf ty) diff --git a/ghc/compiler/rename/RnPass4.lhs b/ghc/compiler/rename/RnPass4.lhs index 9aaa2e7..5006d17 100644 --- a/ghc/compiler/rename/RnPass4.lhs +++ b/ghc/compiler/rename/RnPass4.lhs @@ -292,7 +292,12 @@ rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc) in mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> lookupClass cname `thenRn4` \ cname' -> - rnPolyType False{-no invisibles-} tv_env ty + + rnPolyType False{-no invisibles-} [] ty + -- The "[]" was tv_env, but that means the InstDecl's tyvars aren't + -- pinned on the HsForAllType, which they should be. + -- Urgh! Improve in the new renamer! + `thenRn4` \ ty' -> rnMethodBinds cname' mbinds `thenRn4` \ mbinds' -> mapRn4 (rn_uprag cname') uprags `thenRn4` \ new_uprags -> diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs index 7e45607..8422c18 100644 --- a/ghc/compiler/simplCore/AnalFBWW.lhs +++ b/ghc/compiler/simplCore/AnalFBWW.lhs @@ -8,29 +8,36 @@ module AnalFBWW ( analFBWW ) where -import Util -import Id ( addIdFBTypeInfo ) -import IdInfo -import PrelInfo ( foldrId, buildId, - nilDataCon, consDataCon, mkListTy, mkFunTy, - unpackCStringAppendId - ) -import BinderInfo -import SimplEnv -- everything -import OccurAnal -- OLD: was NewOccurAnal -import Maybes - +import Ubiq{-uitous-} + +import CoreSyn ( CoreBinding(..) ) +import Util ( panic{-ToDo:rm-} ) + +--import Util +--import Id ( addIdFBTypeInfo ) +--import IdInfo +--import PrelInfo ( foldrId, buildId, +-- nilDataCon, consDataCon, mkListTy, mkFunTy, +-- unpackCStringAppendId +-- ) +--import BinderInfo +--import SimplEnv -- everything +--import OccurAnal -- OLD: was NewOccurAnal +--import Maybes \end{code} \begin{code} analFBWW - :: (GlobalSwitch -> Bool) - -> [CoreBinding] + :: [CoreBinding] -> [CoreBinding] -analFBWW switch top_binds = trace "ANALFBWW" (snd anno) + +analFBWW = panic "analFBWW (ToDo)" + +{- LATER: +analFBWW top_binds = trace "ANALFBWW" (snd anno) where anals :: [InBinding] - anals = newOccurAnalyseBinds top_binds switch (const False) + anals = newOccurAnalyseBinds top_binds (const False) anno = mapAccumL annotateBindingFBWW nullIdEnv anals \end{code} @@ -136,14 +143,14 @@ 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 (AlgAlts alts deflt) env = - case analDefFBWW deflt env of +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 (PrimAlts alts deflt) env = - case analDefFBWW deflt env of +analAltsFBWW (PrimAlts alts deflt) env + = case analDefFBWW deflt env of Just ty -> ty : tys Nothing -> tys where @@ -162,8 +169,8 @@ Only add a type info if: \begin{code} analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType -analBindExpr bnd expr env = - case analExprFBWW expr env of +analBindExpr bnd expr env + = case analExprFBWW expr env of IsFB ty@(FBType [] _) -> if oneSafeOcc False bnd then IsFB ty @@ -246,4 +253,5 @@ annotateBindingFBWW env bnds = (env',bnds') | not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v) (addIdFBTypeInfo v (mkFBTypeInfo ty)) _ -> v) +-} \end{code} diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 27b6c08..0eb1529 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -172,12 +172,11 @@ fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) body) where whnf :: CoreExprWithFVs -> Bool - whnf (_,AnnLit _) = True - whnf (_,AnnCon _ _) = True - whnf (_,AnnLam (ValBinder _) _) = True - whnf (_,AnnLam _ e) = whnf e - whnf (_,AnnSCC _ e) = whnf e - whnf _ = False + whnf (_,AnnLit _) = True + whnf (_,AnnCon _ _) = True + whnf (_,AnnLam x e) = if isValBinder x then True else whnf e + whnf (_,AnnSCC _ e) = whnf e + whnf _ = False \end{code} Applications: we could float inside applications, but it's probably diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs index 7c97d54..99fa850 100644 --- a/ghc/compiler/simplCore/FoldrBuildWW.lhs +++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs @@ -8,38 +8,43 @@ module FoldrBuildWW ( mkFoldrBuildWW ) where -IMPORT_Trace -import Outputable -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 PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon, - foldrId, buildId - ) -import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo, - replaceIdInfo, mkSysLocal, idType - ) -import IdInfo -import Maybes -import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) -import Util +import Ubiq{-uitous-} + +import CoreSyn ( CoreBinding(..) ) +import Util ( panic{-ToDo:rm?-} ) + +--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 PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon, +-- foldrId, buildId +-- ) +--import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo, +-- replaceIdInfo, mkSysLocal, idType +-- ) +--import IdInfo +--import Maybes +--import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +--import Util \end{code} \begin{code} mkFoldrBuildWW - :: (GlobalSwitch -> Bool) - -> UniqSupply + :: UniqSupply -> [CoreBinding] -> [CoreBinding] -mkFoldrBuildWW switch us top_binds = + +mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)" + +{- LATER: +mkFoldrBuildWW us top_binds = (mapWw wwBind top_binds `thenWw` \ top_binds2 -> - returnWw (concat top_binds2)) us switch + returnWw (concat top_binds2)) us \end{code} \begin{code} @@ -176,5 +181,5 @@ try_split_bind id expr = else returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)] _ -> returnWw [(id,expr')] +-} \end{code} - diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs index a56b4c9..47d0a27 100644 --- a/ghc/compiler/simplCore/MagicUFs.lhs +++ b/ghc/compiler/simplCore/MagicUFs.lhs @@ -14,6 +14,7 @@ module MagicUFs ( ) where import Ubiq{-uitous-} +import IdLoop -- paranoia checking import CoreSyn import PrelInfo ( mkListTy ) @@ -317,8 +318,8 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) foldr_fun _ _ = returnSmpl Nothing isConsFun :: SimplEnv -> CoreArg -> Bool -isConsFun env (VarArg v) = - case lookupUnfolding env v of +isConsFun env (VarArg v) + = case lookupUnfolding env v of GenForm _ _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _ | con == consDataCon && x==x' && y==y' @@ -327,8 +328,8 @@ isConsFun env (VarArg v) = isConsFun env _ = False isNilForm :: SimplEnv -> CoreArg -> Bool -isNilForm env (VarArg v) = - case lookupUnfolding env v of +isNilForm env (VarArg v) + = case lookupUnfolding env v of GenForm _ _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True ConForm id _ _ @@ -338,8 +339,8 @@ isNilForm env (VarArg v) = isNilForm env _ = False getBuildForm :: SimplEnv -> CoreArg -> Maybe Id -getBuildForm env (VarArg v) = - case lookupUnfolding env v of +getBuildForm env (VarArg v) + = case lookupUnfolding env v of GenForm False _ _ _ -> Nothing -- not allowed to inline :-( GenForm _ _ (App (CoTyApp (Var bld) _) (VarArg g)) _ @@ -353,8 +354,8 @@ getBuildForm env _ = Nothing getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg) -getAugmentForm env (VarArg v) = - case lookupUnfolding env v of +getAugmentForm env (VarArg v) + = case lookupUnfolding env v of GenForm False _ _ _ -> Nothing -- not allowed to inline :-( GenForm _ _ (App (App (CoTyApp (Var bld) _) @@ -387,8 +388,8 @@ getListForm :: SimplEnv -> CoreArg -> Maybe ([CoreArg],CoreArg) -getListForm env (VarArg v) = - case lookupUnfolding env v of +getListForm env (VarArg v) + = case lookupUnfolding env v of ConForm id _ [head,tail] | id == consDataCon -> case getListForm env tail of @@ -398,8 +399,8 @@ getListForm env (VarArg v) = getListForm env _ = Nothing isInterestingArg :: SimplEnv -> CoreArg -> Bool -isInterestingArg env (VarArg v) = - case lookupUnfolding env v of +isInterestingArg env (VarArg v) + = case lookupUnfolding env v of GenForm False _ _ UnfoldNever -> False GenForm _ _ exp guide -> True _ -> False diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index b04eb4b..94e9fc6 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % %************************************************************************ %* * @@ -15,19 +15,34 @@ core expression with (hopefully) improved usage information. module OccurAnal ( occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr - - -- and to make the interface self-sufficient... ) where -import Type +import Ubiq{-uitous-} + import BinderInfo -import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) ) +import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) +import CoreSyn import Digraph ( stronglyConnComp ) -import Id ( eqId, idWantsToBeINLINEd, isConstMethodId, - isSpecPragmaId_maybe, SpecInfo ) -import Maybes -import UniqSet -import Util +import Id ( idWantsToBeINLINEd, isConstMethodId, + emptyIdSet, unionIdSets, mkIdSet, + unitIdSet, elementOfIdSet, + addOneToIdSet, IdSet(..), + nullIdEnv, unitIdEnv, combineIdEnvs, + delOneFromIdEnv, delManyFromIdEnv, + mapIdEnv, lookupIdEnv, IdEnv(..), + GenId{-instance Eq-} + ) +import Maybes ( maybeToBool ) +import Outputable ( isExported, Outputable(..){-instance * (,) -} ) +import PprCore +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) +import Pretty ( ppAboves ) +import TyVar ( GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instance Eq-} ) +import Util ( assoc, pprTrace, panic ) + +isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)" \end{code} @@ -56,18 +71,18 @@ data OccEnv = Bool -- IgnoreINLINEPragma flag -- False <=> OK to use INLINEPragma information -- True <=> ignore INLINEPragma information - (UniqSet Id) -- Candidates + IdSet -- Candidates addNewCands :: OccEnv -> [Id] -> OccEnv addNewCands (OccEnv kd ks kc ip cands) ids - = OccEnv kd ks kc ip (cands `unionUniqSets` mkUniqSet ids) + = OccEnv kd ks kc ip (cands `unionIdSets` mkIdSet ids) addNewCand :: OccEnv -> Id -> OccEnv addNewCand (OccEnv ks kd kc ip cands) id - = OccEnv kd ks kc ip (cands `unionUniqSets` singletonUniqSet id) + = OccEnv kd ks kc ip (addOneToIdSet cands id) isCandidate :: OccEnv -> Id -> Bool -isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands +isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfIdSet` cands ignoreINLINEPragma :: OccEnv -> Bool ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip @@ -86,37 +101,34 @@ combineUsageDetails, combineAltsUsageDetails :: UsageDetails -> UsageDetails -> UsageDetails combineUsageDetails usage1 usage2 - = --BSCC("combineUsages") - combineIdEnvs combineBinderInfo usage1 usage2 - --ESCC + = combineIdEnvs combineBinderInfo usage1 usage2 combineAltsUsageDetails usage1 usage2 - = --BSCC("combineUsages") - combineIdEnvs combineAltsBinderInfo usage1 usage2 - --ESCC + = combineIdEnvs combineAltsBinderInfo usage1 usage2 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails -addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info) +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 :: 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] + [ (binder, usage_of usage binder) | binder <- binders ] ) -tagBinder :: UsageDetails -- Of scope - -> Id -- Binders - -> (UsageDetails, -- Details with binders removed - (Id,BinderInfo)) -- Tagged binders +tagBinder :: UsageDetails -- Of scope + -> Id -- Binders + -> (UsageDetails, -- Details with binders removed + (Id,BinderInfo)) -- Tagged binders tagBinder usage binder = (usage `delOneFromIdEnv` binder, @@ -126,12 +138,12 @@ tagBinder usage binder usage_of usage binder | isExported binder = ManyOcc 0 -- Exported things count as many | otherwise - = case lookupIdEnv usage binder of + = case (lookupIdEnv usage binder) of Nothing -> DeadCode 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} @@ -148,13 +160,14 @@ Here's the externally-callable interface: \begin{code} occurAnalyseBinds :: [CoreBinding] -- input - -> (GlobalSwitch -> Bool) -> (SimplifierSwitch -> Bool) -> [SimplifiableCoreBinding] -- output -occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr - | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds' - | otherwise = binds' +occurAnalyseBinds binds simplifier_sw_chkr + | opt_D_dump_occur_anal = pprTrace "OccurAnal:" + (ppAboves (map (ppr PprDebug) binds')) + binds' + | otherwise = binds' where (_, binds') = do initial_env binds @@ -162,7 +175,7 @@ occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr (simplifier_sw_chkr KeepSpecPragmaIds) (not (simplifier_sw_chkr SimplMayDeleteConjurableIds)) (simplifier_sw_chkr IgnoreINLINEPragma) - emptyUniqSet + emptyIdSet do env [] = (emptyDetails, []) do env (bind:binds) @@ -170,15 +183,13 @@ occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr 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 + (final_usage, new_binds) = occAnalBind env bind binds_usage \end{code} \begin{code} -occurAnalyseExpr :: UniqSet Id -- Set of interesting free vars +occurAnalyseExpr :: IdSet -- Set of interesting free vars -> CoreExpr - -> (IdEnv BinderInfo, -- Occ info for interesting free vars + -> (IdEnv BinderInfo, -- Occ info for interesting free vars SimplifiableCoreExpr) occurAnalyseExpr candidates expr @@ -194,7 +205,7 @@ occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr occurAnalyseGlobalExpr expr = -- Top level expr, so no interesting free vars, and -- discard occurence info returned - expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr + expr' where (_, expr') = occurAnalyseExpr emptyIdSet expr \end{code} %************************************************************************ @@ -291,7 +302,7 @@ occAnalBind env (Rec pairs) body_usage sccs :: [[Id]] sccs = case binders of [_] -> [binders] -- Singleton; no need to analyse - other -> stronglyConnComp eqId edges binders + other -> stronglyConnComp (==) edges binders ---- stuff to "re-constitute" bindings from dependency-analysis info ------ @@ -336,7 +347,7 @@ ToDo: try using the occurrence info for the inline'd binder. \begin{code} occAnalRhs :: OccEnv - -> Id -- Binder + -> Id -- Binder -> CoreExpr -- Rhs -> (UsageDetails, SimplifiableCoreExpr) @@ -356,7 +367,7 @@ Expressions \begin{code} occAnal :: OccEnv -> CoreExpr - -> (UsageDetails, -- Gives info only about the "interesting" Ids + -> (UsageDetails, -- Gives info only about the "interesting" Ids SimplifiableCoreExpr) occAnal env (Var v) @@ -367,8 +378,8 @@ occAnal env (Var v) = (emptyDetails, Var v) 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 (Con con args) = (occAnalArgs env args, Con con args) +occAnal env (Prim op args) = (occAnalArgs env args, Prim op args) occAnal env (SCC cc body) = (mapIdEnv markInsideSCC usage, SCC cc body') @@ -378,26 +389,25 @@ occAnal env (SCC cc body) 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 + (fun_usage, fun') = occAnal env fun + arg_usage = occAnalArg env arg -occAnal env (CoTyApp fun ty) - = (fun_usage, CoTyApp fun' ty) +occAnal env (Lam (ValBinder binder) body) + = (mapIdEnv markDangerousToDup final_usage, + Lam (ValBinder tagged_binder) body') where - (fun_usage, fun') = occAnal env fun - -occAnal env (Lam binder body) - = (mapIdEnv markDangerousToDup final_usage, Lam tagged_binder body') - where - (body_usage, body') = occAnal (env `addNewCand` binder) body + (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) - = (mapIdEnv markDangerousToDup body_usage, CoTyLam tyvar body') +occAnal env (Lam (TyBinder tyvar) body) + = (mapIdEnv markDangerousToDup body_usage, + Lam (TyBinder tyvar) body') where (body_usage, body') = occAnal env body +occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder" + occAnal env (Case scrut alts) = (scrut_usage `combineUsageDetails` alts_usage, Case scrut' alts') @@ -410,9 +420,7 @@ occAnal env (Let bind body) where new_env = env `addNewCands` (bindersOf bind) (body_usage, body') = occAnal new_env body - (final_usage, new_binds) = --BSCC("occAnalBind2") - occAnalBind env bind body_usage - --ESCC + (final_usage, new_binds) = occAnalBind env bind body_usage \end{code} Case alternatives @@ -460,21 +468,21 @@ occAnalDeflt env (BindDefault binder rhs) Atoms ~~~~~ \begin{code} -occAnalAtoms :: OccEnv -> [CoreArg] -> UsageDetails +occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails -occAnalAtoms env atoms +occAnalArgs env atoms = foldr do_one_atom emptyDetails atoms where - do_one_atom (LitArg lit) usage = usage do_one_atom (VarArg v) usage | isCandidate env v = addOneOcc usage v (argOccurrence 0) | otherwise = usage + do_one_atom other_arg usage = usage -occAnalAtom :: OccEnv -> CoreArg -> UsageDetails +occAnalArg :: OccEnv -> CoreArg -> UsageDetails -occAnalAtom env (LitArg lit) = emptyDetails -occAnalAtom env (VarArg v) +occAnalArg env (VarArg v) | isCandidate env v = unitDetails v (argOccurrence 0) | otherwise = emptyDetails +occAnalArg _ _ = emptyDetails \end{code} diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 7c70bca..6783e11 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1995 +% (c) The AQUA Project, Glasgow University, 1994-1996 % \section[SimplCase]{Simplification of `case' expression} @@ -10,33 +10,35 @@ Support code for @Simplify@. module SimplCase ( simplCase, bindLargeRhs ) where -import SimplMonad -import SimplEnv +import Ubiq{-uitous-} +import SmplLoop ( simplBind, simplExpr, MagicUnfoldingFun ) -import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp, - voidPrimTy, voidPrimId, mkFunTy, primOpOkForSpeculation - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import BinderInfo -- too boring to try to select things... +import CmdLineOpts ( SimplifierSwitch(..) ) +import CoreSyn +import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..), + FormSummary(..) ) -import Type ( splitSigmaTy, splitTyArgs, glueTyArgs, - getTyConFamilySize, isPrimType, - maybeAppDataTyCon +import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp, + unTagBindersAlts ) -import Literal ( isNoRepLit, Literal ) -import CmdLineOpts ( SimplifierSwitch(..) ) -import Id -import IdInfo -import Maybes ( catMaybes, maybeToBool, Maybe(..) ) -import Simplify -import SimplUtils -import SimplVar ( completeVar ) -import Util +import Id ( idType, isDataCon, getIdDemandInfo, + DataCon(..), GenId{-instance Eq-} + ) +import IdInfo ( willBeDemanded, DemandInfo ) +import Literal ( isNoRepLit, Literal{-instance Eq-} ) +import Maybes ( maybeToBool ) +import PrelInfo ( voidPrimTy, voidPrimId ) +import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} ) +import SimplEnv +import SimplMonad +import SimplUtils ( mkValLamTryingEta ) +import Type ( isPrimType, maybeAppDataTyCon, mkFunTys, eqTy ) +import Unique ( Unique{-instance Eq-} ) +import Usage ( GenUsage{-instance Eq-} ) +import Util ( isIn, isSingleton, panic, assertPanic ) \end{code} - - - - Float let out of case. \begin{code} @@ -44,7 +46,7 @@ simplCase :: SimplEnv -> InExpr -- Scrutinee -> InAlts -- Alternatives -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler - -> OutUniType -- Type of result expression + -> OutType -- Type of result expression -> SmplM OutExpr simplCase env (Let bind body) alts rhs_c result_ty @@ -185,10 +187,10 @@ completeCase env (Lit lit) alts rhs_c tick KnownBranch `thenSmpl_` completePrimCaseWithKnownLit env lit alts rhs_c -completeCase env expr@(Con con tys con_args) alts rhs_c +completeCase env expr@(Con con 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 + completeAlgCaseWithKnownCon env con con_args alts rhs_c \end{code} Case elimination @@ -310,7 +312,7 @@ completeCase env scrut alts rhs_c not (alt_con `is_elem` not_these)] #ifdef DEBUG --- ConForm c t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (ppr PprDebug alts)) +-- ConForm c v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppStr ""]) (ppr PprDebug alts)) -- ConForm can't happen, since we'd have -- inlined it, and be in completeCaseWithKnownCon by now #endif @@ -328,19 +330,19 @@ completeCase env scrut alts rhs_c -- If the scrut is already eval'd then there's no worry about -- eliminating the case scrut_is_evald = case scrut_form of - OtherLitForm _ -> True - ConForm _ _ _ -> True - OtherConForm _ -> True - other -> False + OtherLitForm _ -> True + ConForm _ _ -> True + OtherConForm _ -> True + other -> False scrut_is_eliminable_primitive = case scrut of - Prim op _ _ -> primOpOkForSpeculation op - Var _ -> case alts of - PrimAlts _ _ -> True -- Primitive, hence non-bottom - AlgAlts _ _ -> False -- Not primitive - other -> False + 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 @@ -390,7 +392,7 @@ completeCase env scrut alts rhs_c bindLargeAlts :: SimplEnv -> InAlts -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler - -> OutUniType -- Result type + -> OutType -- Result type -> SmplM ([OutBinding], -- Extra bindings InAlts) -- Modified alts @@ -427,7 +429,7 @@ bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c \begin{code} bindLargeRhs :: SimplEnv -> [InBinder] -- The args wrt which the rhs should be abstracted - -> OutUniType + -> OutType -> (SimplEnv -> SmplM OutExpr) -- Rhs handler -> SmplM (OutBinding, -- New bindings (singleton or empty) InExpr) -- Modified rhs @@ -473,15 +475,15 @@ bindLargeRhs env args rhs_ty rhs_c -- 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 (idType id) | (id,_) <- used_args] rhs_ty + rhs_fun_ty :: OutType + rhs_fun_ty = mkFunTys [simplTy env (idType id) | (id,_) <- used_args] rhs_ty used_args = [arg | arg@(_,usage) <- args, not (dead usage)] used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args] dead DeadCode = True dead other = False - prim_rhs_fun_ty = mkFunTy voidPrimTy rhs_ty + prim_rhs_fun_ty = mkFunTys [voidPrimTy] rhs_ty \end{code} Case alternatives when we don't know the scrutinee @@ -517,8 +519,8 @@ simplAlts env scrut (AlgAlts alts deflt) rhs_c let env1 = extendIdEnvWithClones env con_args con_args' new_env = case scrut of - Var var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args') - other -> env1 + Var v -> extendUnfoldEnvGivenConstructor env1 v con con_args' + other -> env1 in rhs_c new_env rhs `thenSmpl` \ rhs' -> returnSmpl (con, con_args', rhs') @@ -532,8 +534,8 @@ simplAlts env scrut (PrimAlts alts deflt) rhs_c do_alt (lit, rhs) = let new_env = case scrut of - Var var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LitForm lit)) - other -> env + Var v -> extendUnfoldEnvGivenFormDetails env v (LitForm lit) + other -> env in rhs_c new_env rhs `thenSmpl` \ rhs' -> returnSmpl (lit, rhs') @@ -588,12 +590,12 @@ simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rh final_form = case (form_from_this_case, scrut_form) of (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds) - (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds) + (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds) -- ConForm, LitForm impossible -- (ASSERT? ASSERT? Hello? WDP 95/05) - other -> form_from_this_case + other -> form_from_this_case - env2 = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' final_form) + env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form -- Change unfold details for scrut var. We now want to unfold it -- to binder' @@ -609,7 +611,7 @@ simplDefault env scrut (BindDefault binder rhs) form rhs_c = cloneId env binder `thenSmpl` \ binder' -> let env1 = extendIdEnvWithAtom env binder (VarArg binder') - new_env = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' form) + new_env = extendUnfoldEnvGivenFormDetails env1 binder' form in rhs_c new_env rhs `thenSmpl` \ rhs' -> returnSmpl (BindDefault binder' rhs') @@ -663,13 +665,13 @@ var [substitute \tr{y} out of existence]. \begin{code} completeAlgCaseWithKnownCon :: SimplEnv - -> DataCon -> [Type] -> [InAtom] + -> DataCon -> [InArg] -- Scrutinee is (con, type, value arguments) -> InAlts -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler -> SmplM OutExpr -completeAlgCaseWithKnownCon env con tys con_args (AlgAlts alts deflt) rhs_c +completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c = ASSERT(isDataCon con) search_alts alts where @@ -698,11 +700,11 @@ completeAlgCaseWithKnownCon env con tys con_args (AlgAlts alts deflt) rhs_c cloneId env binder `thenSmpl` \ id' -> let env1 = extendIdEnvWithClone env binder id' - new_env = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id' - (ConForm con tys con_args)) + new_env = extendUnfoldEnvGivenFormDetails env1 id' + (ConForm con con_args) in rhs_c new_env rhs `thenSmpl` \ rhs' -> - returnSmpl (Let (NonRec id' (Con con tys con_args)) rhs') + returnSmpl (Let (NonRec id' (Con con con_args)) rhs') \end{code} Case absorption and identity-case elimination @@ -787,7 +789,7 @@ mkCoCase scrut (AlgAlts outer_alts munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs) where v | scrut_is_var = Var scrut_var - | otherwise = Con con arg_tys (map VarArg args) + | otherwise = Con con (map TyArg arg_tys ++ map VarArg args) arg_tys = case maybeAppDataTyCon (idType deflt_var) of Just (_, arg_tys, _) -> arg_tys @@ -856,7 +858,7 @@ mkCoCase scrut alts 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, Con con' _ args') + identity_alg_alt (con, args, Con con' args') = con == con' && and (zipWith eq_arg args args') && length args == length args' @@ -913,26 +915,30 @@ munge_alg_deflt deflt_var (BindDefault d' rhs) \end{code} \begin{code} - -- A cheap equality test which bales out fast! cheap_eq :: InExpr -> InExpr -> Bool + -- A cheap equality test which bales out fast! + 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 (Prim op1 tys1 args1) (Prim op2 tys2 args2) = (op1==op2) && - (args1 `eq_args` args2) - -- Types bound to be equal -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 (Con con1 args1) (Con con2 args2) + = con1 == con2 && args1 `eq_args` args2 + +cheap_eq (Prim op1 args1) (Prim op2 args2) + = op1 ==op2 && args1 `eq_args` args2 + +cheap_eq (App f1 a1) (App f2 a2) + = f1 `cheap_eq` f2 && a1 `eq_arg` a2 + cheap_eq _ _ = False -- 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 (LitArg l1) (LitArg l2) = l1==l2 -eq_atom (VarArg v1) (VarArg v2) = v1==v2 -eq_atom other1 other2 = False +eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2 +eq_args [] [] = True +eq_args _ _ = False + +eq_arg (LitArg l1) (LitArg l2) = l1 == l2 +eq_arg (VarArg v1) (VarArg v2) = v1 == v2 +eq_arg (TyArg t1) (TyArg t2) = t1 `eqTy` t2 +eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2 +eq_arg _ _ = False \end{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 2ada373..1c99c71 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -1,61 +1,84 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[SimplCore]{Driver for simplifying @Core@ programs} \begin{code} #include "HsVersions.h" -module SimplCore ( - core2core - ) where +module SimplCore ( core2core ) where -import Type ( getTyConDataCons ) ---SAVE:import ArityAnal ( arityAnalProgram ) -import Bag -import BinderInfo ( BinderInfo) -- instances only +import Ubiq{-uitous-} + +import AnalFBWW ( analFBWW ) +import Bag ( isEmptyBag, foldBag ) +import BinderInfo ( BinderInfo{-instance Outputable-} ) import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD, uNFOLDING_USE_THRESHOLD, uNFOLDING_OVERRIDE_THRESHOLD, uNFOLDING_CON_DISCOUNT_WEIGHT ) -import CmdLineOpts +import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn, + opt_D_show_passes, + opt_D_simplifier_stats, + opt_D_verbose_core2core, + opt_DoCoreLinting, + opt_FoldrBuildOn, + opt_ReportWhyUnfoldingsDisallowed, + opt_ShowImportSpecs, + opt_UnfoldingCreationThreshold, + opt_UnfoldingOverrideThreshold, + opt_UnfoldingUseThreshold + ) import CoreLint ( lintCoreBindings ) +import CoreSyn +import CoreUnfold +import CoreUtils ( substCoreBindings, manifestlyWHNF ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( getIdUnfolding, - idType, toplevelishId, - idWantsToBeINLINEd, - unfoldingUnfriendlyId, isWrapperId, - mkTemplateLocals +import FoldrBuildWW ( mkFoldrBuildWW ) +import Id ( idType, toplevelishId, idWantsToBeINLINEd, + unfoldingUnfriendlyId, + nullIdEnv, addOneToIdEnv, delOneFromIdEnv, + lookupIdEnv, IdEnv(..), + GenId{-instance Outputable-} ) -import IdInfo +import IdInfo ( mkUnfolding ) import LiberateCase ( liberateCase ) -import MainMonad -import Maybes +import MagicUFs ( MagicUnfoldingFun ) +import MainMonad ( writeMn, exitMn, thenMn, thenMn_, returnMn, + MainIO(..) + ) +import Maybes ( maybeToBool ) +import Outputable ( Outputable(..){-instance * (,) -} ) +import PprCore ( pprCoreBinding, GenCoreExpr{-instance Outputable-} ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) +import Pretty ( ppShow, ppAboves, ppAbove, ppCat, ppStr ) import SAT ( doStaticArgs ) -import SCCauto ---ANDY: ---import SimplHaskell ( coreToHaskell ) -import SimplMonad ( zeroSimplCount, showSimplCount, TickType, SimplCount ) +import SCCauto ( addAutoCostCentres ) +import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount ) import SimplPgm ( simplifyPgm ) import SimplVar ( leastItCouldCost ) import Specialise import SpecUtils ( pprSpecErrs ) import StrictAnal ( saWwTopBinds ) -import FoldrBuildWW -import AnalFBWW +import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instance Eq-} ) +import UniqSupply ( splitUniqSupply ) +import Util ( panic{-ToDo:rm-} ) + #if ! OMIT_DEFORESTER import Deforest ( deforestProgram ) import DefUtils ( deforestable ) #endif -import UniqSupply -import Util + +isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)" +isWrapperId = panic "SimplCore.isWrapperId (ToDo)" \end{code} \begin{code} core2core :: [CoreToDo] -- spec of what core-to-core passes to do - -> (GlobalSwitch->SwitchResult)-- "global" command-line info lookup fn -> FAST_STRING -- module name (profiling only) -> PprStyle -- printing style (for debugging only) -> UniqSupply -- a name supply @@ -67,12 +90,14 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do IdEnv UnfoldingDetails, -- unfoldings to be exported from here SpecialiseData) -- specialisation data -core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs binds +core2core core_todos module_name ppr_style us local_tycons tycon_specs binds = BSCC("Core2Core") if null core_todos then -- very rare, I suspect... -- well, we still must do some renumbering returnMn ( - (snd (instCoreBindings (mkUniqueSupplyGrimily us) binds), nullIdEnv, init_specdata) + (substCoreBindings nullIdEnv nullTyVarEnv binds us, + nullIdEnv, + init_specdata) ) else (if do_verbose_core2core then @@ -85,7 +110,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b core_todos `thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) -> - (if switch_is_on D_simplifier_stats + (if opt_D_simplifier_stats then writeMn stderr ("\nSimplifier Stats:\n") `thenMn_` writeMn stderr (showSimplCount simpl_stats) @@ -99,18 +124,16 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b where init_specdata = initSpecData local_tycons tycon_specs - switch_is_on = switchIsOn sw_chkr - - do_verbose_core2core = switch_is_on D_verbose_core2core + do_verbose_core2core = opt_D_verbose_core2core lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME -- Use 4x a known threshold - = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of + = case opt_UnfoldingOverrideThreshold of Nothing -> 4 * uNFOLDING_USE_THRESHOLD Just xx -> 4 * xx ------------- - core_linter = if switch_is_on DoCoreLinting + core_linter = if opt_DoCoreLinting then lintCoreBindings ppr_style else ( \ whodunnit spec_done binds -> binds ) @@ -124,7 +147,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b -> BSCC("CoreSimplify") begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild then " (foldr/build)" else "") `thenMn_` - case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of + case (simplifyPgm binds 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 ++ ")" @@ -135,14 +158,14 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b CoreDoFoldrBuildWorkerWrapper -> BSCC("CoreDoFoldrBuildWorkerWrapper") begin_pass "FBWW" `thenMn_` - case (mkFoldrBuildWW switch_is_on us1 binds) of { binds2 -> + case (mkFoldrBuildWW us1 binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" } ESCC CoreDoFoldrBuildWWAnal -> BSCC("CoreDoFoldrBuildWWAnal") begin_pass "AnalFBWW" `thenMn_` - case (analFBWW switch_is_on binds) of { binds2 -> + case (analFBWW binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" } ESCC @@ -156,14 +179,14 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres -> BSCC("CoreInlinings1") begin_pass "CalcInlinings" `thenMn_` - case (calcInlinings False sw_chkr inline_env binds) of { inline_env2 -> + case (calcInlinings False inline_env binds) of { inline_env2 -> end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" } ESCC CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres -> BSCC("CoreInlinings2") begin_pass "CalcInlinings" `thenMn_` - case (calcInlinings True sw_chkr inline_env binds) of { inline_env2 -> + case (calcInlinings True inline_env binds) of { inline_env2 -> end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" } ESCC @@ -177,7 +200,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b CoreDoFullLaziness -> BSCC("CoreFloating") begin_pass "FloatOut" `thenMn_` - case (floatOutwards switch_is_on us1 binds) of { binds2 -> + case (floatOutwards us1 binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" } ESCC @@ -194,20 +217,20 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b CoreDoStrictness -> BSCC("CoreStranal") begin_pass "StrAnal" `thenMn_` - case (saWwTopBinds us1 switch_is_on binds) of { binds2 -> + case (saWwTopBinds us1 binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" } ESCC CoreDoSpecialising -> BSCC("Specialise") begin_pass "Specialise" `thenMn_` - case (specProgram switch_is_on us1 binds spec_data) of { + case (specProgram us1 binds spec_data) of { (p, spec_data2@(SpecData _ spec_noerrs _ _ _ spec_errs spec_warn spec_tyerrs)) -> -- if we got errors, we die straight away (if not spec_noerrs || - (switch_is_on ShowImportSpecs && not (isEmptyBag spec_warn)) then + (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then writeMn stderr (ppShow 1000 {-pprCols-} (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs)) `thenMn_` writeMn stderr "\n" @@ -229,7 +252,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b #else -> BSCC("Deforestation") begin_pass "Deforestation" `thenMn_` - case (deforestProgram sw_chkr binds us1) of { binds2 -> + case (deforestProgram binds us1) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" } ESCC @@ -238,7 +261,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b CoreDoAutoCostCentres -> BSCC("AutoSCCs") begin_pass "AutoSCCs" `thenMn_` - case (addAutoCostCentres sw_chkr module_name binds) of { binds2 -> + case (addAutoCostCentres module_name binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs" } ESCC @@ -250,7 +273,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b ------------------------------------------------- begin_pass - = if switch_is_on D_show_passes + = if opt_D_show_passes then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n") else \ what -> returnMn () @@ -264,7 +287,7 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b writeMn stderr ("\n*** "++what++":\n") `thenMn_` writeMn stderr (ppShow 1000 - (ppAboves (map (pprPlainCoreBinding ppr_style) binds2))) + (ppAboves (map (pprCoreBinding ppr_style) binds2))) `thenMn_` writeMn stderr "\n" else @@ -307,12 +330,11 @@ will be visible on the other side of an interface, too. \begin{code} calcInlinings :: Bool -- True => inlinings with _scc_s are OK - -> (GlobalSwitch -> SwitchResult) -> IdEnv UnfoldingDetails -> [CoreBinding] -> IdEnv UnfoldingDetails -calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds +calcInlinings scc_s_OK inline_env_so_far top_binds = let result = foldl calci inline_env_so_far top_binds in @@ -323,30 +345,28 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details] where pp_det NoUnfoldingDetails = ppStr "_N_" - pp_det (IWantToBeINLINEd _) = ppStr "INLINE" +--LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE" pp_det (GenForm _ _ expr guide) = ppAbove (ppr PprDebug guide) (ppr PprDebug expr) pp_det other = ppStr "???" ------------ - switch_is_on = switchIsOn sw_chkr - - my_trace = if (switch_is_on ReportWhyUnfoldingsDisallowed) + my_trace = if opt_ReportWhyUnfoldingsDisallowed then trace else \ msg stuff -> stuff (unfolding_creation_threshold, explicit_creation_threshold) - = case (intSwitchSet sw_chkr UnfoldingCreationThreshold) of + = case opt_UnfoldingCreationThreshold of Nothing -> (uNFOLDING_CREATION_THRESHOLD, False) Just xx -> (xx, True) unfold_use_threshold - = case (intSwitchSet sw_chkr UnfoldingUseThreshold) of + = case opt_UnfoldingUseThreshold of Nothing -> uNFOLDING_USE_THRESHOLD Just xx -> xx unfold_override_threshold - = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of + = case opt_UnfoldingOverrideThreshold of Nothing -> uNFOLDING_OVERRIDE_THRESHOLD Just xx -> xx @@ -378,20 +398,15 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds which = if scc_s_OK then " (late):" else " (early):" in - --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 ) - --) | rhs `isWrapperFor` binder -- Don't add an explicit "unfolding"; let the worker/wrapper -- stuff do its thing. INLINE things don't get w/w'd, so -- they will be OK. - = --pprTrace "giving up on isWrapperFor:" (ppr PprDebug binder) - ignominious_defeat + = ignominious_defeat #if ! OMIT_DEFORESTER -- For the deforester: bypass the barbed wire for recursive @@ -474,8 +489,8 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds rhs_looks_like_a_data_val = case (collectBinders rhs) of - (_, _, [], Con _ _ _) -> True - other -> False + (_, _, [], Con _ _) -> True + other -> False rhs_arg_tys = case (collectBinders rhs) of @@ -485,13 +500,11 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds = mentionedInUnfolding (\x -> x) rhs rhs_mentions_an_unmentionable - = --pprTrace "mentions:" (ppCat [ppr PprDebug binder, ppr PprDebug [(i,unfoldingUnfriendlyId i) | i <- mentioned_ids ]]) ( - any unfoldingUnfriendlyId mentioned_ids + = foldBag (||) unfoldingUnfriendlyId False mentioned_ids || mentions_litlit - --) -- ToDo: probably need to chk tycons/classes... - mentions_no_other_ids = null mentioned_ids + mentions_no_other_ids = isEmptyBag mentioned_ids explicit_INLINE_requested -- did it come from a user {-# INLINE ... #-}? @@ -530,7 +543,7 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds = let new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs) - foldr_building = switch_is_on FoldrBuildOn + foldr_building = opt_FoldrBuildOn in if (not have_inlining_already) then -- Not in env: we take it no matter what diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 6712d6a..ee87e0a 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -58,6 +58,7 @@ import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails, ) import FiniteMap -- lots of things import Id ( idType, getIdUnfolding, getIdStrictness, + applyTypeEnvToId, nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, addOneToIdEnv, modifyIdEnv, IdEnv(..), IdSet(..), GenId ) @@ -68,19 +69,18 @@ import PprCore -- various instances import PprStyle ( PprStyle(..) ) import PprType ( GenType, GenTyVar ) import Pretty -import Type ( getAppDataTyCon ) +import Type ( getAppDataTyCon, applyTypeEnvToTy ) import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, growTyVarEnvList, - TyVarEnv(..), GenTyVar ) -import Unique ( Unique ) + TyVarEnv(..), GenTyVar{-instance Eq-} + ) +import Unique ( Unique{-instance Outputable-} ) 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)" @@ -303,7 +303,7 @@ grow_unfold_env (UFE u_env interesting_ids con_apps) id -- 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)) - (interesting_ids `unionUniqSets` singletonUniqSet id) + (addOneToUniqSet interesting_ids id) con_apps grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc @@ -496,7 +496,6 @@ extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs new_ty_env = growTyVarEnvList ty_env pairs simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty - simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id \end{code} @@ -768,7 +767,7 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) -- (This is brought to you by *ANDY* Magic Constants, Inc.) is_really_small = case collectArgs new_rhs of - (Var _, xs) -> length xs < 10 + (Var _, _, _, xs) -> length xs < 10 _ -> False -} \end{code} diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index bc8fac7..1569843 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -26,18 +26,16 @@ import Ubiq{-uitous-} import SmplLoop -- well, cheating sort of -import Id ( mkSysLocal ) +import Id ( mkSysLocal, mkIdWithNewUniq ) import SimplEnv import SrcLoc ( mkUnknownSrcLoc ) +import TyVar ( cloneTyVar ) import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) import Util ( zipWithEqual, panic ) infixr 9 `thenSmpl`, `thenSmpl_` - -cloneTyVar = panic "cloneTyVar (SimplMonad)" -mkIdWithNewUniq = panic "mkIdWithNewUniq (SimplMonad)" \end{code} %************************************************************************ diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs index ee791a6..dc9d1c4 100644 --- a/ghc/compiler/simplCore/SimplPgm.lhs +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -1,47 +1,52 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % -\section[SimplPgm]{Interface to the ``new'' simplifier} +\section[SimplPgm]{Interface to the simplifier} \begin{code} #include "HsVersions.h" module SimplPgm ( simplifyPgm ) where -import Type ( getTyVarMaybe ) -import CmdLineOpts ( switchIsOn, intSwitchSet, - GlobalSwitch(..), SimplifierSwitch(..) +import Ubiq{-uitous-} + +import CmdLineOpts ( opt_D_verbose_core2core, + switchIsOn, intSwitchSet, SimplifierSwitch(..) + ) +import CoreSyn +import CoreUtils ( substCoreExpr ) +import Id ( externallyVisibleId, + mkIdEnv, lookupIdEnv, IdEnv(..), + GenId{-instance Ord3-} ) -import Id ( externallyVisibleId ) -import IdInfo -import Maybes ( catMaybes, Maybe(..) ) -import Outputable +import Maybes ( catMaybes ) +import OccurAnal ( occurAnalyseBinds ) +import Outputable ( isExported ) +import Pretty ( ppAboves, ppBesides, ppInt, ppChar, ppStr ) import SimplEnv import SimplMonad import Simplify ( simplTopBinds ) -import OccurAnal -- occurAnalyseBinds -import UniqSupply -import Util +import TyVar ( nullTyVarEnv, TyVarEnv(..) ) +import UniqSupply ( thenUs, returnUs, mapUs, splitUniqSupply, UniqSM(..) ) +import Util ( isIn, isn'tIn, removeDups, pprTrace ) \end{code} \begin{code} -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 +simplifyPgm :: [CoreBinding] -- input + -> (SimplifierSwitch->SwitchResult) + -> SimplCount -- info about how many times + -- each transformation has occurred -> UniqSupply -> ([CoreBinding], -- output - Int, -- info about how much happened - SimplCount) -- accumulated simpl stats + Int, -- info about how much happened + SimplCount) -- accumulated simpl stats -simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us +simplifyPgm binds s_sw_chkr simpl_stats us = case (splitUniqSupply us) of { (s1, s2) -> case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) -> case (tidy_top pgm2 s2) of { pgm3 -> (pgm3, it_count, combineSimplCounts simpl_stats simpl_stats2) }}} where - global_switch_is_on = switchIsOn g_sw_chkr simpl_switch_is_on = switchIsOn s_sw_chkr occur_anal = occurAnalyseBinds @@ -56,11 +61,8 @@ simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us simpl_pgm n iterations pgm = -- find out what top-level binders are used, -- and prepare to unfold all the "simple" bindings - -- pprTrace ("\niteration "++show iterations++":\n") (ppr PprDebug pgm) ( let - tagged_pgm = BSCC("OccurBinds") - occur_anal pgm global_switch_is_on simpl_switch_is_on - ESCC + tagged_pgm = occur_anal pgm simpl_switch_is_on in -- do the business simplTopBinds (nullSimplEnv s_sw_chkr) tagged_pgm `thenSmpl` \ new_pgm -> @@ -74,11 +76,11 @@ simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us show_status = pprTrace "NewSimpl: " (ppAboves [ ppBesides [ppInt iterations, ppChar '/', ppInt max_simpl_iterations], ppStr (showSimplCount dr) ---DEBUG: , ppAboves (map (pprPlainCoreBinding PprDebug) new_pgm) +--DEBUG: , ppAboves (map (pprCoreBinding PprDebug) new_pgm) ]) in - (if global_switch_is_on D_verbose_core2core + (if opt_D_verbose_core2core || simpl_switch_is_on ShowSimplifierProgress then show_status else id) @@ -98,7 +100,6 @@ simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us else simpl_pgm r (iterations + 1) new_pgm ) - -- ) \end{code} In @tidy_top@, we look for things at the top-level of the form... @@ -131,10 +132,8 @@ tidy_top binds_in = if null blast_alist then returnUs binds_in -- no joy there else - -- pprTrace "undup output length:" (ppInt (length blast_alist)) ( 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 @@ -158,13 +157,11 @@ tidy_top binds_in undup :: [(Id, Id)] -> [(Id, Id)] undup blast_list - = -- pprTrace "undup input length:" (ppInt (length blast_list)) ( - let + = let (singles, dups) = removeDups compare blast_list list_of_dups = concat dups in [ s | s <- singles, s `not_elem` list_of_dups ] - -- ) where compare (x,_) (y,_) = x `cmp` y @@ -186,25 +183,23 @@ tidy_top binds_in returnUs (Just (Rec blasted_pairs)) where blast_pr (binder, rhs) - = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs -> + = substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs -> returnUs ( - case lookupIdEnv blast_id_env binder of - Just exportee -> (exportee, blasted_rhs) - Nothing -> (binder, blasted_rhs) + case (lookupIdEnv blast_id_env binder) of + Just exportee -> (exportee, new_rhs) + Nothing -> (binder, new_rhs) ) blast (NonRec binder rhs) = if binder `is_elem` blast_all_exps then returnUs Nothing -- this binding dies! else - subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs -> + substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs -> returnUs (Just ( - case lookupIdEnv blast_id_env binder of - Just exportee -> NonRec exportee blasted_rhs - Nothing -> NonRec binder blasted_rhs + case (lookupIdEnv blast_id_env binder) of + Just exportee -> NonRec exportee new_rhs + Nothing -> NonRec binder new_rhs )) where is_elem = isIn "blast" - -subst_CoreExprUS e1 e2 rhs us = snd (substCoreExprUS e1 e2 rhs (mkUniqueSupplyGrimily us)) \end{code} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 3f5c1a5..f546fbc 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -24,18 +24,23 @@ module SimplUtils ( import Ubiq{-uitous-} import BinderInfo +import CmdLineOpts ( SimplifierSwitch(..) ) import CoreSyn import CoreUtils ( manifestlyWHNF ) -import Id ( idType, isBottomingId, getIdArity ) +import Id ( idType, isBottomingId, idWantsToBeINLINEd, + getIdArity, GenId{-instance Eq-} + ) import IdInfo ( arityMaybe ) import Maybes ( maybeToBool ) import PrelInfo ( augmentId, buildId, realWorldStateTy ) +import PrimOp ( primOpIsCheap ) import SimplEnv import SimplMonad -import Type ( isPrimType, maybeAppDataTyCon, getTyVar_maybe ) +import Type ( eqTy, isPrimType, maybeAppDataTyCon, getTyVar_maybe ) +import TyVar ( GenTyVar{-instance Eq-} ) import Util ( isIn, panic ) -primOpIsCheap = panic "SimplUtils. (ToDo)" +getInstantiatedDataConSig = panic "SimplUtils.getInstantiatedDataConSig (ToDo)" \end{code} @@ -50,13 +55,13 @@ floatExposesHNF :: Bool -- Float let(rec)s out of rhs -> Bool -- Float cheap primops out of rhs -> Bool -- OK to duplicate code - -> GenCoreExpr bdr Id + -> GenCoreExpr bdr Id tyvar uvar -> Bool floatExposesHNF float_lets float_primops ok_to_dup rhs = try rhs where - try (Case (Prim _ _ _) (PrimAlts alts deflt) ) + try (Case (Prim _ _) (PrimAlts alts deflt) ) | float_primops && (null alts || ok_to_dup) = or (try_deflt deflt : map try_alt alts) @@ -132,7 +137,7 @@ mkValLamTryingEta orig_ids body reduce_it (id:ids) (App fun (VarArg arg)) | id == arg - && idType id /= realWorldStateTy + && not (idType id `eqTy` realWorldStateTy) -- *never* eta-reduce away a PrimIO state token! (WDP 94/11) = reduce_it ids fun @@ -171,7 +176,7 @@ arguments as you care to give it. For this special case we return 100, to represent "infinity", which is a bit of a hack. \begin{code} -etaExpandCount :: GenCoreExpr bdr Id +etaExpandCount :: GenCoreExpr bdr Id tyvar uvar -> Int -- Number of extra args you can safely abstract etaExpandCount (Lam (ValBinder _) body) @@ -200,8 +205,8 @@ etaExpandCount other = 0 -- Give up -- Case with non-whnf scrutinee ----------------------------- -eta_fun :: GenCoreExpr bdr Id -- The function - -> Int -- How many args it can safely be applied to +eta_fun :: GenCoreExpr bdr Id tv uv -- The function + -> Int -- How many args it can safely be applied to eta_fun (App fun arg) | notValArg arg = eta_fun fun @@ -240,17 +245,14 @@ which aren't WHNF but are ``cheap'' are: where op is a cheap primitive operator \begin{code} -manifestlyCheap :: GenCoreExpr bndr Id -> Bool +manifestlyCheap :: GenCoreExpr bndr Id tv uv -> Bool -manifestlyCheap (Var _) = True -manifestlyCheap (Lit _) = True -manifestlyCheap (Con _ _ _) = True -manifestlyCheap (SCC _ e) = manifestlyCheap e - -manifestlyCheap (Lam (ValBinder _) _) = True -manifestlyCheap (Lam other_binder e) = manifestlyCheap e - -manifestlyCheap (Prim op _ _) = primOpIsCheap op +manifestlyCheap (Var _) = True +manifestlyCheap (Lit _) = True +manifestlyCheap (Con _ _) = True +manifestlyCheap (SCC _ e) = manifestlyCheap e +manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e +manifestlyCheap (Prim op _) = primOpIsCheap op manifestlyCheap (Let bind body) = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind) @@ -259,7 +261,7 @@ 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 (collectArgs other_expr) of { (fun, _, _, vargs) -> case fun of Var f | isBottomingId f -> True -- Application of a function which @@ -268,7 +270,7 @@ manifestlyCheap other_expr -- look for manifest partial application -- need to be shared! Var f -> let - num_val_args = numValArgs args + num_val_args = length vargs in num_val_args == 0 || -- Just a type application of -- a variable (f t1 t2 t3) @@ -381,7 +383,7 @@ mkIdentityAlts rhs_ty in returnSmpl ( AlgAlts - [(data_con, new_binders, Con data_con ty_args (map VarArg new_bindees))] + [(data_con, new_binders, mkCon data_con [] ty_args (map VarArg new_bindees))] NoDefault ) diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index c0a91cd..84555a7 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -11,26 +11,31 @@ module SimplVar ( leastItCouldCost ) where -import SimplMonad -import SimplEnv -import Literal ( isNoRepLit ) +import Ubiq{-uitous-} +import SmplLoop ( simplExpr ) -import Type ( getAppDataTyCon, maybeAppDataTyCon, - getTyConFamilySize, isPrimType - ) -import BinderInfo ( oneTextualOcc, oneSafeOcc ) import CgCompInfo ( uNFOLDING_USE_THRESHOLD, uNFOLDING_CON_DISCOUNT_WEIGHT ) -import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) ) -import Id ( idType, getIdInfo ) -import IdInfo -import Maybes ( maybeToBool, Maybe(..) ) -import Simplify ( simplExpr ) -import SimplUtils ( simplIdWantsToBeINLINEd ) -import MagicUFs -import Pretty -import Util +import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) ) +import CoreSyn +import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..), + FormSummary(..) + ) +import Id ( idType, getIdInfo, + GenId{-instance Outputable-} + ) +import IdInfo ( DeforestInfo(..) ) +import Literal ( isNoRepLit ) +import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-} ) +import Pretty ( ppBesides, ppStr ) +import SimplEnv +import SimplMonad +import TyCon ( tyConFamilySize ) +import Type ( isPrimType, getAppDataTyCon, maybeAppDataTyCon ) +import Util ( pprTrace, assertPanic, panic ) \end{code} %************************************************************************ @@ -56,11 +61,11 @@ completeVar env var args -> ASSERT( null args ) returnSmpl (Lit lit) - ConForm con ty_args val_args + ConForm con args -- Always inline constructors. -- See comments before completeLetBinding -> ASSERT( null args ) - returnSmpl (Con con ty_args val_args) + returnSmpl (Con con args) GenForm txt_occ form_summary template guidance -> considerUnfolding env var args @@ -82,7 +87,8 @@ completeVar env var args tick MagicUnfold `thenSmpl_` returnSmpl magic_result - IWantToBeINLINEd _ -> returnSmpl boring_result +-- LATER: +-- IWantToBeINLINEd _ -> returnSmpl boring_result other -> returnSmpl boring_result \end{code} @@ -135,7 +141,7 @@ considerUnfolding env var args txt_occ form_summary template guidance = go_for_it | (case form_summary of {BottomForm -> True; other -> False} && - not (any isPrimType [ ty | (TypeArg ty) <- args ])) + not (any isPrimType [ ty | (TyArg ty) <- args ])) -- Always inline bottoming applications, unless -- there's a primitive type lurking around... = go_for_it @@ -193,16 +199,19 @@ considerUnfolding env var args txt_occ form_summary template guidance con_discount -- ToDo: ************ get from a switch ********* = uNFOLDING_CON_DISCOUNT_WEIGHT - (tyargs, valargs, args_left) = decomposeArgs args + (_, _, tyargs, valargs) = collectArgs args_in_dummy_expr no_tyargs = length tyargs no_valargs = length valargs + args_in_dummy_expr = mkGenApp (Var (panic "SimplVar.dummy")) args + -- we concoct this dummy expr, just so we can use collectArgs + -- (rather than make up a special-purpose bit of code) rhs_looks_like_a_Con = let (_,_,val_binders,body) = collectBinders template in case (val_binders, body) of - ([], Con _ _ _) -> True + ([], Con _ _) -> True other -> False dont_go_for_it = returnSmpl (mkGenApp (Var var) args) @@ -229,7 +238,7 @@ discountedCost -> Int -- the size/cost of the expr -> 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*! + -> [OutArg] -- *an actual set of value arguments*! -> Int -- If we apply an expression (usually a function) of given "costs" @@ -249,8 +258,7 @@ discountedCost env con_discount_weight size no_args is_con_vec args full_price = disc size take_something_off v = let (tycon, _, _) = getAppDataTyCon (idType v) - no_cons = case (getTyConFamilySize tycon) of - Just n -> n + no_cons = tyConFamilySize tycon reduced_size = size - (no_cons * con_discount_weight) in @@ -262,8 +270,8 @@ discountedCost env con_discount_weight size no_args is_con_vec args case arg of LitArg _ -> full_price VarArg v -> case lookupUnfolding env v of - ConForm _ _ _ -> take_something_off v - other_form -> full_price + ConForm _ _ -> take_something_off v + other_form -> full_price ) want_cons rest_args \end{code} @@ -294,7 +302,7 @@ leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys = let take_something_off tycon = let - no_cons = case (getTyConFamilySize tycon) of { Just n -> n } + no_cons = tyConFamilySize tycon reduced_size = size - (no_cons * con_discount_weight) diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 36591fc..962b6d0 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -8,34 +8,38 @@ module Simplify ( simplTopBinds, simplExpr, simplBind ) where -import Pretty -- these are for debugging only -import Outputable +import Ubiq{-uitous-} +import SmplLoop -- paranoia checking -import SimplMonad -import SimplEnv - -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 Type ( maybeAppDataTyCon, mkTyVarTy, mkTyVarTys, applyTy, - splitTyArgs, splitTypeWithDictsAsArgs, - maybeUnpackFunTy, isPrimType - ) -import Literal ( isNoRepLit, Literal(..) ) import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) import ConFold ( completePrim ) -import Id -import IdInfo -import Maybes ( Maybe(..), catMaybes, maybeToBool ) -import SimplCase -import SimplUtils +import CoreSyn +import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, + unTagBinders, squashableDictishCcExpr, + manifestlyWHNF + ) +import Id ( idType, idWantsToBeINLINEd, + getIdDemandInfo, addIdDemandInfo, + GenId{-instance NamedThing-} + ) +import IdInfo ( willBeDemanded, DemandInfo ) +import Literal ( isNoRepLit ) +import Maybes ( maybeToBool ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-} ) +import PrelInfo ( realWorldStateTy ) +import Pretty ( ppAbove ) +import PrimOp ( primOpOkForSpeculation, PrimOp(..) ) +import SimplCase ( simplCase, bindLargeRhs ) +import SimplEnv +import SimplMonad import SimplVar ( completeVar ) -import Util +import SimplUtils +import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, + splitFunTy, getFunTy_maybe, eqTy + ) +import Util ( isSingleton, panic, pprPanic, assertPanic ) \end{code} The controlling flags, and what they do @@ -122,12 +126,12 @@ would occur]. But consider: f = \y -> ...y...y...y... in f x @ -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@. +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@. -Becuase of this, the "unconditional-inline" mechanism above is the only way -in which non-HNFs can get inlined. +Because of this, the "unconditional-inline" mechanism above is the +only way in which non-HNFs can get inlined. INLINE pragmas ~~~~~~~~~~~~~~ @@ -185,12 +189,10 @@ simplTopBinds env [] = returnSmpl [] 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 + = let new_env = extendIdEnvWithInlining env env binder rhs in simplTopBinds new_env binds - --) where ok_to_dup_code = switchIsSet env SimplOkToDupCode @@ -200,12 +202,10 @@ simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds) simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> let new_env = case rhs' of - Var var -> extendIdEnvWithAtom env binder (VarArg var) - Lit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (LitArg lit) - other -> extendUnfoldEnvGivenRhs env binder in_id rhs' + Var v -> extendIdEnvWithAtom env binder (VarArg v) + Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i) + other -> extendUnfoldEnvGivenRhs env binder in_id rhs' in - --pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug rhs']) ( - -- Process the other bindings simplTopBinds new_env binds `thenSmpl` \ binds' -> @@ -214,19 +214,15 @@ simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds) -- an unused atom binding. This localises the decision about -- discarding top-level bindings. returnSmpl (NonRec in_id rhs' : binds') - --) simplTopBinds env (Rec pairs : binds) = simplRecursiveGroup env triples `thenSmpl` \ (bind', new_env) -> - --pprTrace "simplTopBinds (rec):" (ppCat [ppr PprDebug bind']) ( - -- Process the other bindings simplTopBinds new_env binds `thenSmpl` \ binds' -> -- Glue together and return returnSmpl (bind' : binds') - --) where triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs] -- No cloning necessary at top level @@ -251,15 +247,14 @@ applied to the specified arguments. Variables ~~~~~~~~~ -Check if there's a macro-expansion, and if so rattle on. Otherwise -do the more sophisticated stuff. +Check if there's a macro-expansion, and if so rattle on. Otherwise do +the more sophisticated stuff. \begin{code} simplExpr env (Var v) args - = --pprTrace "simplExpr:Var:" (ppr PprDebug v) ( - case lookupId env v of + = case (lookupId env v) of Nothing -> let - new_v = simplTyInId env v + new_v = simplTyInId env v in completeVar env new_v args @@ -278,15 +273,16 @@ simplExpr env (Var v) args InlineIt id_env ty_env in_expr -- A macro-expansion -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args - --) \end{code} Literals -~~~~~~~~~ +~~~~~~~~ \begin{code} simplExpr env (Lit l) [] = returnSmpl (Lit l) +#ifdef DEBUG simplExpr env (Lit l) _ = panic "simplExpr:Lit with argument" +#endif \end{code} Primitive applications are simple. @@ -296,14 +292,13 @@ NB: Prim expects an empty argument list! (Because it should be saturated and not higher-order. ADR) \begin{code} -simplExpr env (Prim op tys prim_args) args +simplExpr env (Prim op prim_args) args = ASSERT (null args) let - tys' = [simplTy env ty | ty <- tys] - prim_args' = [simplAtom env prim_arg | prim_arg <- prim_args] + prim_args' = [simplArg env prim_arg | prim_arg <- prim_args] op' = simpl_op op in - completePrim env op' tys' prim_args' + completePrim env op' prim_args' where -- PrimOps just need any types in them renamed. @@ -323,12 +318,9 @@ Nothing to try here. We only reuse constructors when they appear as the rhs of a let binding (see completeLetBinding). \begin{code} -simplExpr env (Con con tys con_args) args +simplExpr env (Con con con_args) args = ASSERT( null args ) - returnSmpl (Con con tys' con_args') - where - con_args' = [simplAtom env con_arg | con_arg <- con_args] - tys' = [simplTy env ty | ty <- tys] + returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args]) \end{code} @@ -338,10 +330,7 @@ Just stuff 'em in the arg stack \begin{code} simplExpr env (App fun arg) args - = simplExpr env fun (ValArg (simplAtom env arg) : args) - -simplExpr env (CoTyApp fun ty) args - = simplExpr env fun (TypeArg (simplTy env ty) : args) + = simplExpr env fun (simplArg env arg : args) \end{code} Type lambdas @@ -352,7 +341,7 @@ be eta-reduced. This requires us to collect up all tyvar parameters so we can pass them all to @mkTyLamTryingEta@. \begin{code} -simplExpr env (CoTyLam tyvar body) (TypeArg ty : args) +simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) = -- ASSERT(not (isPrimType ty)) let new_env = extendTyEnv env tyvar ty @@ -360,10 +349,10 @@ simplExpr env (CoTyLam tyvar body) (TypeArg ty : args) tick TyBetaReduction `thenSmpl_` simplExpr new_env body args -simplExpr env tylam@(CoTyLam tyvar body) [] +simplExpr env tylam@(Lam (TyBinder tyvar) body) [] = do_tylambdas env [] tylam where - do_tylambdas env tyvars' (CoTyLam tyvar body) + do_tylambdas env tyvars' (Lam (TyBinder tyvar) body) = -- Clone the type variable cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' -> let @@ -376,11 +365,13 @@ simplExpr env tylam@(CoTyLam tyvar body) [] returnSmpl ( (if switchIsSet env SimplDoEtaReduction then mkTyLamTryingEta - else mkCoTyLam) (reverse tyvars') body' + else mkTyLam) (reverse tyvars') body' ) -simplExpr env (CoTyLam tyvar body) (ValArg _ : _) - = panic "simplExpr:CoTyLam ValArg" +#ifdef DEBUG +simplExpr env (Lam (TyBinder _) _) (_ : _) + = panic "simplExpr:TyLam with non-TyArg" +#endif \end{code} @@ -388,7 +379,7 @@ Ordinary lambdas ~~~~~~~~~~~~~~~~ \begin{code} -simplExpr env (Lam binder body) args +simplExpr env (Lam (ValBinder binder) body) args | null leftover_binders = -- The lambda is saturated (or over-saturated) tick BetaReduction `thenSmpl_` @@ -407,7 +398,7 @@ simplExpr env (Lam binder body) args 0 {- Guaranteed applied to at least 0 args! -} where - (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args [binder] args + (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs @@ -427,24 +418,23 @@ simplExpr env (Lam binder body) args zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg) | ((id, occ_info), arg) <- binder_args_pairs ] - collect_val_args :: [InBinder] -- Binders - -> [OutArg] -- Arguments - -> ([(InBinder,OutAtom)], -- Binder,arg pairs - [InBinder], -- Leftover binders - [OutArg]) -- Leftover args + collect_val_args :: InBinder -- Binder + -> [OutArg] -- Arguments + -> ([(InBinder,OutArg)], -- Binder,arg pairs (ToDo: a maybe?) + [InBinder], -- Leftover binders (ToDo: a maybe) + [OutArg]) -- Leftover args -- collect_val_args strips off the leading ValArgs from -- the current arg list, returning them along with the -- depleted list - collect_val_args [] args = ([], [], args) - collect_val_args binders [] = ([], binders, []) - collect_val_args (binder:binders) (ValArg val_arg : args) - = ((binder,val_arg):rest_pairs, leftover_binders, leftover_args) - where - (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 Lam + collect_val_args binder [] = ([], [binder], []) + collect_val_args binder (arg : args) | isValArg arg + = ([(binder,arg)], [], args) + +#ifdef DEBUG + collect_val_args _ (other_val_arg : _) = panic "collect_val_args" + -- TyArg should never meet a Lam +#endif \end{code} @@ -486,9 +476,6 @@ interfaces change less (arities). \begin{code} simplExpr env (SCC cc (Lam binder body)) args = simplExpr env (Lam binder (SCC 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: @@ -559,7 +546,7 @@ simplRhsExpr env binder@(id,occ_info) rhs returnSmpl ( (if switchIsSet env SimplDoEtaReduction then mkTyLamTryingEta - else mkCoTyLam) tyvars' lambda' + else mkTyLam) tyvars' lambda' ) where -- Note from ANDY: @@ -590,10 +577,12 @@ simplRhsExpr env binder@(id,occ_info) rhs -- 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 (Con _ _ _) = True - dont_eta_expand _ = False + dont_eta_expand (Con _ _) = True + dont_eta_expand (App f a) + | notValArg a = dont_eta_expand f + dont_eta_expand (Lam x b) + | notValBinder x = dont_eta_expand b + dont_eta_expand _ = False \end{code} @@ -628,8 +617,8 @@ simplLam env binders body min_no_of_args let new_env = extendIdEnvWithClones env binders binders' in - newIds extra_binder_tys `thenSmpl` \ extra_binders' -> - simplExpr new_env body (map (ValArg.VarArg) extra_binders') `thenSmpl` \ body' -> + newIds extra_binder_tys `thenSmpl` \ extra_binders' -> + simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' -> returnSmpl ( (if switchIsSet new_env SimplDoEtaReduction then mkValLamTryingEta @@ -638,7 +627,7 @@ simplLam env binders body min_no_of_args where (potential_extra_binder_tys, res_ty) - = splitTyArgs (simplTy env (coreExprType (unTagBinders body))) + = splitFunTy (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 @@ -661,8 +650,8 @@ simplLam env binders body min_no_of_args -- but usually doesn't `max` case potential_extra_binder_tys of - [ty] | ty == realWorldStateTy -> 1 - other -> 0 + [ty] | ty `eqTy` realWorldStateTy -> 1 + other -> 0 \end{code} @@ -677,7 +666,7 @@ simplLam env binders body min_no_of_args simplBind :: SimplEnv -> InBinding -> (SimplEnv -> SmplM OutExpr) - -> OutUniType + -> OutType -> SmplM OutExpr \end{code} @@ -1028,8 +1017,8 @@ simplRecursiveGroup env triples (early_triples, late_triples) = partition is_early_triple ordinary_triples - is_early_triple (_, (_, Con _ _ _)) = True - is_early_triple (i, _ ) = idWantsToBeINLINEd i + is_early_triple (_, (_, Con _ _)) = True + is_early_triple (i, _ ) = idWantsToBeINLINEd i in -- Process the early bindings first mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' -> @@ -1102,7 +1091,7 @@ completeLet -> InExpr -- Original RHS -> OutExpr -- The simplified RHS -> (SimplEnv -> SmplM OutExpr) -- Body handler - -> OutUniType -- Type of body + -> OutType -- Type of body -> SmplM OutExpr completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty @@ -1126,7 +1115,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty = cloneId env binder `thenSmpl` \ id' -> let env1 = extendIdEnvWithClone env binder id' - new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs) + new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs in body_c new_env `thenSmpl` \ body' -> returnSmpl (Let (NonRec id' new_rhs) body') @@ -1137,7 +1126,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs - maybe_atomic_rhs :: Maybe (OutAtom, TickType) + maybe_atomic_rhs :: Maybe (OutArg, TickType) -- If the RHS is atomic, we return Just (atom, tick type) -- otherwise Nothing @@ -1148,7 +1137,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty Lit lit | not (isNoRepLit lit) -> Just (LitArg lit, AtomicRhs) - Con con tys con_args + Con con con_args | try_to_reuse_constr -- Look out for -- let v = C args @@ -1156,7 +1145,7 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty --- ...(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 + -> case (lookForConstructor env con con_args) of Nothing -> Nothing Just var -> Just (VarArg var, ConReused) @@ -1173,15 +1162,16 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty %************************************************************************ \begin{code} -simplAtom :: SimplEnv -> InAtom -> OutAtom +simplArg :: SimplEnv -> InArg -> OutArg -simplAtom env (LitArg lit) = LitArg lit +simplArg env (LitArg lit) = LitArg lit +simplArg env (TyArg ty) = TyArg (simplTy env ty) -simplAtom env (VarArg id) +simplArg 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)) + Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env)) Nothing -> VarArg id -- Must be an uncloned thing | otherwise @@ -1209,20 +1199,20 @@ fix_up_demandedness False {- May not be demanded -} (Rec pairs) un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info) -is_cheap_prim_app (Prim op tys args) = primOpOkForSpeculation op -is_cheap_prim_app other = False +is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op +is_cheap_prim_app other = False -computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType +computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType computeResultType env expr args - = do expr_ty' args + = go expr_ty' args where expr_ty = coreExprType (unTagBinders expr) expr_ty' = simplTy env expr_ty - do ty [] = ty - do ty (TypeArg ty_arg : args) = do (applyTy ty ty_arg) args - do ty (ValArg a : args) = case maybeUnpackFunTy ty of - Just (_, res_ty) -> do res_ty args - Nothing -> panic "computeResultType" + go ty [] = ty + go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args + go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of + Just (_, res_ty) -> go res_ty args + Nothing -> panic "computeResultType" \end{code} diff --git a/ghc/compiler/simplCore/SmplLoop.lhi b/ghc/compiler/simplCore/SmplLoop.lhi index 89de04b..3a9e349 100644 --- a/ghc/compiler/simplCore/SmplLoop.lhi +++ b/ghc/compiler/simplCore/SmplLoop.lhi @@ -1,10 +1,26 @@ Breaks the loop between SimplEnv and MagicUFs, by telling SimplEnv all it needs to know about MagicUFs (not much). +Also break the loop between SimplVar/SimplCase (which use +Simplify.simplExpr) and SimplExpr (which uses whatever +SimplVar/SimplCase cough up). + \begin{code} interface SmplLoop where -import MagicUFs (MagicUnfoldingFun ) +import MagicUFs ( MagicUnfoldingFun ) +import SimplEnv ( SimplEnv, InBinding(..), InExpr(..), + OutArg(..), OutExpr(..), OutType(..) + ) +import Simplify ( simplExpr, simplBind ) +import SimplMonad ( SmplM(..) ) data MagicUnfoldingFun + +simplExpr :: SimplEnv -> InExpr -> [OutArg] -> SmplM OutExpr +simplBind :: SimplEnv + -> InBinding + -> (SimplEnv -> SmplM OutExpr) + -> OutType + -> SmplM OutExpr \end{code} diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 40d180a..b1c83dd 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1995 +% (c) The AQUA Project, Glasgow University, 1994-1996 % \section[LambdaLift]{A STG-code lambda lifter} @@ -8,18 +8,20 @@ module LambdaLift ( liftProgram ) where +import Ubiq{-uitous-} + import StgSyn -import Type ( mkForallTy, splitForalls, glueTyArgs, - Type, RhoType(..), TauType(..) +import Bag ( emptyBag, unionBags, unitBag, snocBag, bagToList ) +import Id ( idType, mkSysLocal, addIdArity, + mkIdSet, unitIdSet, minusIdSet, + unionManyIdSets, idSetToList, IdSet(..), + nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..) ) -import Bag -import Id ( mkSysLocal, idType, addIdArity, Id ) -import Maybes -import UniqSupply -import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) -import UniqSet -import Util +import SrcLoc ( mkUnknownSrcLoc ) +import Type ( splitForAllTy, mkForAllTys, mkFunTys ) +import UniqSupply ( getUnique, splitUniqSupply ) +import Util ( zipEqual, panic, assertPanic ) \end{code} This is the lambda lifter. It turns lambda abstractions into @@ -251,9 +253,9 @@ liftExpr (StgLet (StgRec pairs) body) let -- Find the free vars of all the rhss, -- excluding the binders themselves. - rhs_free_vars = unionManyUniqSets (map rhsFreeVars rhss) - `minusUniqSet` - mkUniqSet binders + rhs_free_vars = unionManyIdSets (map rhsFreeVars rhss) + `minusIdSet` + mkIdSet binders rhs_info = unionLiftInfos rhs_infos in @@ -335,7 +337,7 @@ isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ isLiftableRec other_rhs = False rhsFreeVars :: StgRhs -> IdSet -rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkUniqSet fvs +rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkIdSet fvs rhsFreeVars other = panic "rhsFreeVars" \end{code} @@ -364,22 +366,18 @@ mkScPieces :: IdSet -- Extra args for the supercombinator mkScPieces extra_arg_set (id, StgRhsClosure cc bi _ upd args body) = ASSERT( n_args > 0 ) -- Construct the rhs of the supercombinator, and its Id - -- this trace blackholes sometimes, don't use it - -- trace ("LL " ++ show (length (uniqSetToList extra_arg_set))) ( newSupercombinator sc_ty arity `thenLM` \ sc_id -> - returnLM ((sc_id, extra_args), (sc_id, sc_rhs)) - --) where n_args = length args - extra_args = uniqSetToList extra_arg_set + extra_args = idSetToList extra_arg_set arity = n_args + length extra_args -- Construct the supercombinator type 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) + (tyvars, rest) = splitForAllTy type_of_original_id + sc_ty = mkForAllTys tyvars (mkFunTys extra_arg_tys rest) sc_rhs = StgRhsClosure cc bi [] upd (extra_args ++ args) body \end{code} @@ -451,9 +449,9 @@ newSupercombinator ty arity ci us idenv lookup :: Id -> LiftM (Id,[Id]) lookup v ci us idenv - = case lookupIdEnv idenv v of - Just result -> result - Nothing -> (v, []) + = case (lookupIdEnv idenv v) of + Just result -> result + Nothing -> (v, []) addScInlines :: [Id] -> [(Id,[Id])] -> LiftM a -> LiftM a addScInlines ids values m ci us idenv @@ -488,14 +486,13 @@ addScInlines ids values m ci us idenv getFinalFreeVars :: IdSet -> LiftM IdSet getFinalFreeVars free_vars ci us idenv - = unionManyUniqSets (map munge_it (uniqSetToList free_vars)) + = unionManyIdSets (map munge_it (idSetToList free_vars)) where munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real" -- free var - munge_it id = case lookupIdEnv idenv id of - Just (_, args) -> mkUniqSet args - Nothing -> singletonUniqSet id - + munge_it id = case (lookupIdEnv idenv id) of + Just (_, args) -> mkIdSet args + Nothing -> unitIdSet id \end{code} diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs index 16c903e..2c9dcfc 100644 --- a/ghc/compiler/simplStg/SatStgRhs.lhs +++ b/ghc/compiler/simplStg/SatStgRhs.lhs @@ -1,8 +1,10 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[SatStgRhs]{Saturates RHSs when they are partial applications} +96/03: This is actually an essential module, as it sets arity info +for the code generator. \begin{display} Subject: arg satis check @@ -58,20 +60,22 @@ This is done for local definitions as well. module SatStgRhs ( satStgRhs ) where +import Ubiq{-uitous-} + import StgSyn -import Type ( splitTypeWithDictsAsArgs, Class, - TyVarTemplate, TauType(..) +import CostCentre ( isCafCC, subsumedCosts, useCurrentCostCentre ) +import Id ( idType, getIdArity, addIdArity, mkSysLocal, + nullIdEnv, addOneToIdEnv, growIdEnvList, + lookupIdEnv, IdEnv(..) ) -import CostCentre -import Id ( mkSysLocal, idType, getIdArity, addIdArity ) -import IdInfo -- SIGH: ( arityMaybe, ArityInfo, OptIdInfo(..) ) -import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) -import UniqSupply -import Util -import Maybes - -type Arity = Int +import IdInfo ( arityMaybe ) +import SrcLoc ( mkUnknownSrcLoc ) +import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) ) +import Util ( panic, assertPanic ) + +splitTypeWithDictsAsArgs = panic "SatStgRhs.splitTypeWithDictsAsArgs (ToDo)" + type Count = Int type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index be139b7..7ecb01c 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -8,7 +8,7 @@ module SimplStg ( stg2stg ) where -IMPORT_Trace +import Ubiq{-uitous-} import StgSyn import StgUtils @@ -16,36 +16,43 @@ import StgUtils import LambdaLift ( liftProgram ) import SCCfinal ( stgMassageForProfiling ) import SatStgRhs ( satStgRhs ) +import StgLint ( lintStgBindings ) +import StgSAT ( doStaticArgs ) import StgStats ( showStgStats ) import StgVarInfo ( setStgVarInfo ) import UpdAnal ( updateAnalyse ) -import CmdLineOpts -import Id ( unlocaliseId ) -import MainMonad -import Maybes ( maybeToBool, Maybe(..) ) -import Outputable -import Pretty -import StgLint ( lintStgBindings ) -import StgSAT ( doStaticArgs ) -import UniqSet -import UniqSupply -import Util +import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup, + opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, + StgToDo(..) + ) +import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, + growIdEnvList, isNullIdEnv, IdEnv(..), + GenId{-instance Eq/Outputable -} + ) +import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) ) +import Maybes ( maybeToBool ) +import Outputable ( isExported ) +import PprType ( GenType{-instance Outputable-} ) +import Pretty ( ppShow, ppAbove, ppAboves, ppStr ) +import UniqSupply ( splitUniqSupply ) +import Util ( mapAccumL, panic, assertPanic ) + +unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)" \end{code} \begin{code} -stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do - -> (GlobalSwitch -> SwitchResult)-- access to all global cmd-line opts - -> FAST_STRING -- module name (profiling only) - -> PprStyle -- printing style (for debugging only) +stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do + -> FAST_STRING -- module name (profiling only) + -> PprStyle -- printing style (for debugging only) -> UniqSupply -- a name supply -> [StgBinding] -- input... -> MainIO - ([StgBinding], -- output program... - ([CostCentre], -- local cost-centres that need to be decl'd - [CostCentre])) -- "extern" cost-centres + ([StgBinding], -- output program... + ([CostCentre], -- local cost-centres that need to be decl'd + [CostCentre])) -- "extern" cost-centres -stg2stg stg_todos sw_chkr module_name ppr_style us binds +stg2stg stg_todos module_name ppr_style us binds = BSCC("Stg2Stg") case (splitUniqSupply us) of { (us4now, us4later) -> @@ -98,18 +105,16 @@ stg2stg stg_todos sw_chkr module_name ppr_style us binds }} ESCC where - switch_is_on = switchIsOn sw_chkr - - do_let_no_escapes = switch_is_on StgDoLetNoEscapes - do_verbose_stg2stg = switch_is_on D_verbose_stg2stg + do_let_no_escapes = opt_StgDoLetNoEscapes + do_verbose_stg2stg = opt_D_verbose_stg2stg (do_unlocalising, unlocal_tag) - = case (stringSwitchSet sw_chkr EnsureSplittableC) of + = case (opt_EnsureSplittableC) of Nothing -> (False, panic "tag") - Just tag -> (True, _PK_ tag) + Just tag -> (True, tag) - grp_name = case (stringSwitchSet sw_chkr SccGroup) of - Just xx -> _PK_ xx + grp_name = case (opt_SccGroup) of + Just xx -> xx Nothing -> module_name -- default: module name ------------- @@ -158,7 +163,7 @@ stg2stg stg_todos sw_chkr module_name ppr_style us binds BSCC("ProfMassage") let (collected_CCs, binds3) - = stgMassageForProfiling module_name grp_name us1 switch_is_on binds + = stgMassageForProfiling module_name grp_name us1 binds in end_pass us2 "ProfMassage" collected_CCs binds3 ESCC diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs index c8a5e35..a70205e 100644 --- a/ghc/compiler/simplStg/StgSAT.lhs +++ b/ghc/compiler/simplStg/StgSAT.lhs @@ -33,19 +33,19 @@ useless as map' will be transformed back to what map was. module StgSAT ( doStaticArgs ) where -import Maybes ( Maybe(..) ) +import Ubiq{-uitous-} + import StgSyn -import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv, - SatM(..), initSAT, thenSAT, thenSAT_, - emptyEnvSAT, returnSAT, mapSAT ) -import StgSATMonad -import UniqSupply -import Util +import UniqSupply ( UniqSM(..) ) +import Util ( panic ) \end{code} \begin{code} doStaticArgs :: [StgBinding] -> UniqSupply -> [StgBinding] +doStaticArgs = panic "StgSAT.doStaticArgs" + +{- LATER: to end of file: doStaticArgs binds = initSAT (mapSAT sat_bind binds) where @@ -174,5 +174,5 @@ satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs satRhs (StgRhsClosure cc bi fvs upd args body) = satExpr body `thenSAT` \ body' -> returnSAT (StgRhsClosure cc bi fvs upd args body') +-} \end{code} - diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs index 5996c18..57fff4d 100644 --- a/ghc/compiler/simplStg/StgSATMonad.lhs +++ b/ghc/compiler/simplStg/StgSATMonad.lhs @@ -10,28 +10,14 @@ \begin{code} #include "HsVersions.h" -module StgSATMonad ( - getArgLists, saTransform - ) where - -import Type ( mkSigmaTy, TyVarTemplate, - splitSigmaTy, splitTyArgs, - glueTyArgs, instantiateTy, TauType(..), - Class, ThetaType(..), SigmaType(..), - InstTyEnv(..) - ) -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 ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) -import UniqSupply -import UniqSet ( UniqSet(..), emptyUniqSet ) -import Util +module StgSATMonad ( getArgLists, saTransform ) where +import Ubiq{-uitous-} + +import Util ( panic ) + +getArgLists = panic "StgSATMonad.getArgLists" +saTransform = panic "StgSATMonad.saTransform" \end{code} %************************************************************************ @@ -41,6 +27,8 @@ import Util %************************************************************************ \begin{code} +{- LATER: to end of file: + newSATNames :: [Id] -> SatM [Id] newSATNames [] = returnSAT [] newSATNames (id:ids) = newSATName id (idType id) `thenSAT` \ id' -> @@ -175,4 +163,5 @@ doStgSubst binder orig_args subst_env body = remove_static_args origs as remove_static_args (NotStatic:origs) (a:as) = substAtom a:remove_static_args origs as +-} \end{code} diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs index a513b50..8fba50e 100644 --- a/ghc/compiler/simplStg/StgStats.lhs +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[StgStats]{Gathers statistical information about programs} @@ -25,11 +25,11 @@ The program gather statistics about module StgStats ( showStgStats ) where -import StgSyn +import Ubiq{-uitous-} -import FiniteMap +import StgSyn -import Util +import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList ) \end{code} \begin{code} @@ -63,10 +63,10 @@ combineSEs :: [StatEnv] -> StatEnv combineSEs = foldr combineSE emptySE countOne :: CounterType -> StatEnv -countOne c = singletonFM c 1 +countOne c = unitFM c 1 countN :: CounterType -> Int -> StatEnv -countN = singletonFM +countN = unitFM \end{code} %************************************************************************ diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 258ab15..c43d816 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -11,18 +11,23 @@ let-no-escapes. module StgVarInfo ( setStgVarInfo ) where -IMPORT_Trace -- ToDo: rm (debugging only) -import Pretty -import Outputable +import Ubiq{-uitous-} import StgSyn -import Id ( getIdArity, externallyVisibleId ) -import IdInfo -- ( arityMaybe, ArityInfo ) - -import Maybes ( maybeToBool, Maybe(..) ) -import UniqSet -import Util +import Id ( emptyIdSet, mkIdSet, minusIdSet, + unionIdSets, unionManyIdSets, isEmptyIdSet, + unitIdSet, intersectIdSets, + addOneToIdSet, IdSet(..), + nullIdEnv, growIdEnvList, lookupIdEnv, + unitIdEnv, combineIdEnvs, delManyFromIdEnv, + rngIdEnv, IdEnv(..), + GenId{-instance Eq-} + ) +import Maybes ( maybeToBool ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-} ) +import Util ( panic, pprPanic, assertPanic ) infixr 9 `thenLne`, `thenLne_` \end{code} @@ -116,7 +121,7 @@ varsTopBinds (bind:binds) env_extension = [(b, LetrecBound True {- top level -} (rhsArity rhs) - emptyUniqSet) + emptyIdSet) | (b,rhs) <- pairs] pairs = case bind of @@ -164,9 +169,9 @@ 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 + set_of_args = mkIdSet args rhs_fvs = body_fvs `minusFVBinders` args - rhs_escs = body_escs `minusUniqSet` set_of_args + rhs_escs = body_escs `minusIdSet` set_of_args binder_info = lookupFVInfo scope_fv_info binder in returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2, @@ -227,9 +232,7 @@ decisions. Hence no black holes. \begin{code} varsExpr (StgApp lit@(StgLitArg _) args _) - = --(if null args then id else (trace (ppShow 80 (ppr PprShowAll args)))) ( - returnLne (StgApp lit [] emptyUniqSet, emptyFVInfo, emptyUniqSet) - --) + = returnLne (StgApp lit [] emptyIdSet, emptyFVInfo, emptyIdSet) varsExpr (StgApp fun@(StgVarArg f) args _) = varsApp Nothing f args @@ -257,7 +260,7 @@ varsExpr (StgCase scrut _ _ uniq alts) vars_alts alts `thenLne` \ (alts2, alts_fvs, alts_escs) -> lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs -> let - live_in_alts = live_in_cont `unionUniqSets` alts_lvs + live_in_alts = live_in_cont `unionIdSets` alts_lvs in -- we tell the scrutinee that everything live in the alts -- is live in it, too. @@ -266,12 +269,12 @@ varsExpr (StgCase scrut _ _ uniq alts) ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs -> let - live_in_whole_case = live_in_alts `unionUniqSets` scrut_lvs + live_in_whole_case = live_in_alts `unionIdSets` scrut_lvs in returnLne ( StgCase scrut2 live_in_whole_case live_in_alts uniq alts2, scrut_fvs `unionFVInfo` alts_fvs, - alts_escs `unionUniqSets` (getFVSet scrut_fvs) -- All free vars in the scrutinee escape + alts_escs `unionIdSets` (getFVSet scrut_fvs) -- All free vars in the scrutinee escape ) where vars_alts (StgAlgAlts ty alts deflt) @@ -279,13 +282,13 @@ varsExpr (StgCase scrut _ _ uniq alts) `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> let alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionManyUniqSets alts_escs_list + alts_escs = unionManyIdSets alts_escs_list in vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> returnLne ( StgAlgAlts ty alts2 deflt2, alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionUniqSets` deflt_escs + alts_escs `unionIdSets` deflt_escs ) where vars_alg_alt (con, binders, worthless_use_mask, rhs) @@ -298,7 +301,7 @@ varsExpr (StgCase scrut _ _ uniq alts) returnLne ( (con, binders, good_use_mask, rhs2), rhs_fvs `minusFVBinders` binders, - rhs_escs `minusUniqSet` mkUniqSet binders -- ToDo: remove the minusUniqSet; + rhs_escs `minusIdSet` mkIdSet binders -- ToDo: remove the minusIdSet; -- since escs won't include -- any of these binders )) @@ -308,13 +311,13 @@ varsExpr (StgCase scrut _ _ uniq alts) `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> let alts_fvs = unionFVInfos alts_fvs_list - alts_escs = unionManyUniqSets alts_escs_list + alts_escs = unionManyIdSets alts_escs_list in vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) -> returnLne ( StgPrimAlts ty alts2 deflt2, alts_fvs `unionFVInfo` deflt_fvs, - alts_escs `unionUniqSets` deflt_escs + alts_escs `unionIdSets` deflt_escs ) where vars_prim_alt (lit, rhs) @@ -322,7 +325,7 @@ varsExpr (StgCase scrut _ _ uniq alts) returnLne ((lit, rhs2), rhs_fvs, rhs_escs) vars_deflt StgNoDefault - = returnLne (StgNoDefault, emptyFVInfo, emptyUniqSet) + = returnLne (StgNoDefault, emptyFVInfo, emptyIdSet) vars_deflt (StgBindDefault binder _ rhs) = extendVarEnv [(binder, CaseBound)] ( @@ -333,7 +336,7 @@ varsExpr (StgCase scrut _ _ uniq alts) returnLne ( StgBindDefault binder used_in_rhs rhs2, rhs_fvs `minusFVBinders` [binder], - rhs_escs `minusUniqSet` singletonUniqSet binder + rhs_escs `minusIdSet` unitIdSet binder )) \end{code} @@ -402,17 +405,17 @@ varsApp maybe_thunk_body f args other -> NoStgBinderInfo -- uninteresting variable - myself = singletonUniqSet f + myself = unitIdSet f fun_escs = case how_bound of LetrecBound _ arity lvs -> if arity == n_args then - emptyUniqSet -- Function doesn't escape + emptyIdSet -- Function doesn't escape else myself -- Inexact application; it does escape - other -> emptyUniqSet -- Only letrec-bound escapees + other -> emptyIdSet -- Only letrec-bound escapees -- are interesting -- At the moment of the call: @@ -427,14 +430,14 @@ varsApp maybe_thunk_body f args -- two regardless. live_at_call - = live_in_cont `unionUniqSets` case how_bound of - LetrecBound _ _ lvs -> lvs `minusUniqSet` myself - other -> emptyUniqSet + = live_in_cont `unionIdSets` case how_bound of + LetrecBound _ _ lvs -> lvs `minusIdSet` myself + other -> emptyIdSet in returnLne ( StgApp (StgVarArg f) args live_at_call, fun_fvs `unionFVInfo` args_fvs, - fun_escs `unionUniqSets` (getFVSet args_fvs) + fun_escs `unionIdSets` (getFVSet args_fvs) -- All the free vars of the args are disqualified -- from being let-no-escaped. ) @@ -458,7 +461,7 @@ vars_let let_no_escape bind body -- we ain't in a let-no-escape world getVarsLiveInCont `thenLne` \ live_in_cont -> setVarsLiveInCont - (if let_no_escape then live_in_cont else emptyUniqSet) + (if let_no_escape then live_in_cont else emptyIdSet) (vars_bind rec_bind_lvs rec_body_fvs bind) `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) -> @@ -467,7 +470,7 @@ vars_let let_no_escape bind body -- together with the live_in_cont ones lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) `thenLne` \ lvs_from_fvs -> let - bind_lvs = lvs_from_fvs `unionUniqSets` live_in_cont + bind_lvs = lvs_from_fvs `unionIdSets` live_in_cont in -- bind_fvs and bind_escs still include the binders of the let(rec) @@ -498,7 +501,7 @@ vars_let let_no_escape bind body = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders live_in_whole_let - = bind_lvs `unionUniqSets` (body_lvs `minusUniqSet` set_of_binders) + = bind_lvs `unionIdSets` (body_lvs `minusIdSet` set_of_binders) real_bind_escs = if let_no_escape then bind_escs @@ -506,12 +509,12 @@ vars_let let_no_escape bind body getFVSet bind_fvs -- Everything escapes which is free in the bindings - let_escs = (real_bind_escs `unionUniqSets` body_escs) `minusUniqSet` set_of_binders + let_escs = (real_bind_escs `unionIdSets` body_escs) `minusIdSet` set_of_binders - all_escs = bind_escs `unionUniqSets` body_escs -- Still includes binders of + all_escs = bind_escs `unionIdSets` body_escs -- Still includes binders of -- this let(rec) - no_binder_escapes = isEmptyUniqSet (set_of_binders `intersectUniqSets` all_escs) + no_binder_escapes = isEmptyIdSet (set_of_binders `intersectIdSets` all_escs) -- 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 @@ -525,7 +528,7 @@ vars_let let_no_escape bind body binders = case bind of StgNonRec binder rhs -> [binder] StgRec pairs -> map fst pairs - set_of_binders = mkUniqSet binders + set_of_binders = mkIdSet binders mk_binding bind_lvs (binder,rhs) = (binder, @@ -535,9 +538,9 @@ vars_let let_no_escape bind body ) where live_vars = if let_no_escape then - bind_lvs `unionUniqSets` singletonUniqSet binder + addOneToIdSet bind_lvs binder else - singletonUniqSet binder + unitIdSet binder vars_bind :: StgLiveVars -> FreeVarsInfo -- Free var info for body of binding @@ -567,7 +570,7 @@ vars_let let_no_escape bind body mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) -> let fvs = unionFVInfos fvss - escs = unionManyUniqSets escss + escs = unionManyIdSets escss in returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext) )) @@ -588,15 +591,13 @@ type LneM a = Bool -- True <=> do let-no-escapes -> StgLiveVars -- vars live in continuation -> a -type Arity = Int - data HowBound = ImportBound | CaseBound | LambdaBound | LetrecBound - Bool -- True <=> bound at top level - Arity -- Arity + Bool -- True <=> bound at top level + Arity -- Arity StgLiveVars -- Live vars... see notes below \end{code} @@ -610,7 +611,7 @@ in the LetrecBound constructor; x itself *is* included. The std monad functions: \begin{code} initLne :: Bool -> LneM a -> a -initLne want_LNEs m = m want_LNEs nullIdEnv emptyUniqSet +initLne want_LNEs m = m want_LNEs nullIdEnv emptyIdSet {-# INLINE thenLne #-} {-# INLINE thenLne_ #-} @@ -692,17 +693,17 @@ lookupVarEnv v sw env lvs_cont lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars lookupLiveVarsForSet fvs sw env lvs_cont - = returnLne (unionManyUniqSets (map do_one (getFVs fvs))) + = returnLne (unionManyIdSets (map do_one (getFVs fvs))) sw env lvs_cont where do_one v = if isLocallyDefined v then case (lookupIdEnv env v) of - Just (LetrecBound _ _ lvs) -> lvs `unionUniqSets` singletonUniqSet v - Just _ -> singletonUniqSet v + Just (LetrecBound _ _ lvs) -> addOneToIdSet lvs v + Just _ -> unitIdSet v Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr PprShowAll v) else - emptyUniqSet + emptyIdSet \end{code} @@ -724,7 +725,7 @@ type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo) -- -- The Bool is True <=> the Id is top level letrec bound -type EscVarsSet = UniqSet Id +type EscVarsSet = IdSet \end{code} \begin{code} @@ -756,8 +757,8 @@ lookupFVInfo fvs id = case lookupIdEnv fvs id of getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only getFVs fvs = [id | (id,False,_) <- rngIdEnv fvs] -getFVSet :: FreeVarsInfo -> UniqSet Id -getFVSet fvs = mkUniqSet (getFVs fvs) +getFVSet :: FreeVarsInfo -> IdSet +getFVSet fvs = mkIdSet (getFVs fvs) plusFVInfo (id1,top1,info1) (id2,top2,info2) = ASSERT (id1 == id2 && top1 == top2) diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs index f4ac876..553acac 100644 --- a/ghc/compiler/simplStg/UpdAnal.lhs +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -1,7 +1,7 @@ \section{Update Avoidance Analyser} -*-haskell-literate-*- (c) Simon Marlow, Andre Santos 1992-1993 -(c) The AQUA Project, Glasgow University, 1995 +(c) The AQUA Project, Glasgow University, 1995-1996 %----------------------------------------------------------------------------- \subsection{Module Interface} @@ -12,18 +12,27 @@ > module UpdAnal ( updateAnalyse ) where > -> import Type ( splitTyArgs, splitSigmaTy, Class, TyVarTemplate, -> TauType(..) -> ) -> import Id -> import IdInfo -> import Outputable ( isExported ) -> import Pretty -> import SrcLoc ( mkUnknownSrcLoc ) +> import Ubiq{-uitous-} +> > import StgSyn -> import UniqSet -> import UniqSupply ( getBuiltinUniques ) -> import Util +> import Util ( panic ) +> +> updateAnalyse :: [StgBinding] -> [StgBinding] {- Exported -} +> updateAnalyse = panic "UpdAnal.updateAnalyse" +> +> {- LATER: to end of file: +> --import Type ( splitTyArgs, splitSigmaTy, Class, TyVarTemplate, +> -- TauType(..) +> -- ) +> --import Id +> --import IdInfo +> --import Outputable ( isExported ) +> --import Pretty +> --import SrcLoc ( mkUnknownSrcLoc ) +> --import StgSyn +> --import UniqSet +> --import UniqSupply ( getBuiltinUniques ) +> --import Util %----------------------------------------------------------------------------- \subsection{Reverse application} @@ -503,5 +512,6 @@ suffice for now. > addIdUpdateInfo v > (mkUpdateInfo (mkUpdateSpec v c)) > | otherwise = v +> -} %----------------------------------------------------------------------------- diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs index 374b4c0..64319b8 100644 --- a/ghc/compiler/specialise/SpecEnv.lhs +++ b/ghc/compiler/specialise/SpecEnv.lhs @@ -115,7 +115,8 @@ lookupSpecId unspec_id ty_maybes 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))) + Nothing -> pprError "ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t" + (ppr PprDebug unspec_id) } where try (SpecInfo template_maybes _ id) @@ -188,7 +189,7 @@ lookupSpecEnv se@(SpecEnv spec_infos) spec_tys match [{-out of templates-}] [] = Just [] match (Nothing:ty_maybes) (spec_ty:spec_tys) - = case (isUnboxedDataType spec_ty) of + = case (isUnboxedType spec_ty) of True -> Nothing -- Can only match boxed type against -- type argument which has not been -- specialised on @@ -248,6 +249,6 @@ pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs) 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 + pp_maybe (Just t) = pprParendGenType sty t \end{pseudocode} diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 8a01992..c360e61 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -1,5 +1,5 @@ % -% (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} @@ -21,19 +21,39 @@ module SpecUtils ( pprSpecErrs ) where -import Type -import Bag ( Bag, isEmptyBag, bagToList ) -import FiniteMap ( FiniteMap, emptyFM, addListToFM_C, - plusFM_C, keysFM, lookupWithDefaultFM +import Ubiq{-uitous-} + +import Bag ( isEmptyBag, bagToList ) +import Class ( getClassOpString, GenClass{-instance NamedThing-} ) +import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM, + lookupWithDefaultFM ) -import Id ( mkSameSpecCon, idType, - isDictFunId, isConstMethodId_maybe, +import Id ( idType, isDictFunId, isConstMethodId_maybe, isDefaultMethodId_maybe, - getInstIdModule, Id ) -import Maybes -import Outputable -import Pretty -import Util + GenId {-instance NamedThing -} + ) +import Maybes ( maybeToBool, catMaybes, firstJust ) +import Outputable ( isAvarop, pprNonOp ) +import PprStyle ( PprStyle(..) ) +import PprType ( pprGenType, pprParendGenType, pprMaybeTy, + TyCon{-ditto-}, GenType{-ditto-}, GenTyVar + ) +import Pretty -- plenty of it +import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} ) +import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys, + getTyVar_maybe, isUnboxedType + ) +import TyVar ( GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instance Eq-} ) +import Util ( equivClasses, zipWithEqual, cmpPString, + assertPanic, panic{-ToDo:rm-} + ) + +cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)" +mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)" +getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)" +specialiseTy :: Type -> [Maybe Type] -> Int -> Type +specialiseTy = panic "SpecUtils.specialiseTy (ToDo)" \end{code} @specialiseCallTys@ works out which type args don't need to be specialised on, @@ -52,7 +72,7 @@ specialiseCallTys True _ _ cvec tys specialiseCallTys False spec_unboxed spec_overloading cvec tys = zipWithEqual spec_ty_other cvec tys where - spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty) + spec_ty_other c ty | (spec_unboxed && isUnboxedType ty) || (spec_overloading && c) = Just ty | otherwise @@ -85,16 +105,16 @@ gained by specialising wrt them. \begin{code} getIdOverloading :: Id - -> ([TyVarTemplate], [(Class,TyVarTemplate)]) + -> ([TyVar], [(Class,TyVar)]) getIdOverloading id = (tyvars, tyvar_part_of theta) where (tyvars, theta, _) = splitSigmaTy (idType id) - tyvar_part_of [] = [] - tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of - Nothing -> [] - Just tyvar -> (clas, tyvar) : tyvar_part_of theta + tyvar_part_of [] = [] + tyvar_part_of ((c,ty):theta) = case (getTyVar_maybe ty) of + Nothing -> [] + Just tv -> (c, tv) : tyvar_part_of theta \end{code} \begin{code} @@ -115,7 +135,7 @@ isUnboxedSpecialisation :: [Maybe Type] -> Bool isUnboxedSpecialisation tys = any is_unboxed tys where - is_unboxed (Just ty) = isUnboxedDataType ty + is_unboxed (Just ty) = isUnboxedType ty is_unboxed Nothing = False \end{code} @@ -129,7 +149,7 @@ specialiseConstrTys :: [Type] specialiseConstrTys tys = map maybe_unboxed_ty tys where - maybe_unboxed_ty ty = case isUnboxedDataType ty of + maybe_unboxed_ty ty = case isUnboxedType ty of True -> Just ty False -> Nothing \end{code} @@ -156,13 +176,13 @@ argTysMatchSpecTys_error 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 [pprParendType PprDebug ty | ty <- arg_tys]]) + ppStr "argtys=", ppSep [pprParendGenType PprDebug ty | ty <- arg_tys]]) where match (Nothing:spec_tys) (arg:arg_tys) - = not (isUnboxedDataType arg) && + = not (isUnboxedType arg) && match spec_tys arg_tys match (Just spec:spec_tys) (arg:arg_tys) - = case (cmpUniType True{-properly-} spec arg) of + = case (cmpType True{-properly-} spec arg) of EQ_ -> match spec_tys arg_tys other -> False match [] [] = True @@ -261,7 +281,7 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs 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 "SpecUtils:PprInterface:sw_chkr") + ty_sty = PprInterface pp_module mod = ppBesides [ppPStr mod, ppStr ":"] @@ -271,15 +291,15 @@ 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 (pprParendType sty) spec_tys), + pprNonOp PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys), ppStr "#-}", ppStr "{- Essential -}" ] where - tvs = getTyConTyVarTemplates tycon + tvs = tyConTyVars tycon (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys)) - spec_tys = map (mkForallTy (catMaybes tv_maybes)) spec_args + spec_tys = map (mkForAllTys (catMaybes tv_maybes)) spec_args - choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv) + choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv) choose_ty (tv, Just ty) = (ty, Nothing) pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty @@ -289,7 +309,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) = ppCat [pp_mod, ppStr "{-# SPECIALIZE", ppStr "instance", - pprType sty spec_ty, + pprGenType sty spec_ty, ppStr "#-}", pp_essential ] | is_const_method_id @@ -301,9 +321,9 @@ pp_idspec sty pp_mod (_, id, tys, is_err) ppCat [pp_mod, ppStr "{-# SPECIALIZE", pp_clsop clsop_str, ppStr "::", - pprType sty spec_ty, + pprGenType sty spec_ty, ppStr "#-} {- IN instance", - ppPStr cls_str, pprParendType sty clsty, + ppPStr cls_str, pprParendGenType sty clsty, ppStr "-}", pp_essential ] | is_default_method_id @@ -317,14 +337,14 @@ pp_idspec sty pp_mod (_, id, tys, is_err) ppPStr cls_str, ppStr "EXPLICIT METHOD REQUIRED", pp_clsop clsop_str, ppStr "::", - pprType sty spec_ty, + pprGenType sty spec_ty, ppStr "-}", pp_essential ] | otherwise = ppCat [pp_mod, ppStr "{-# SPECIALIZE", pprNonOp PprForUser id, ppStr "::", - pprType sty spec_ty, + pprGenType sty spec_ty, ppStr "#-}", pp_essential ] where spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!! diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index e96941a..42cd011 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -15,25 +15,84 @@ module Specialise ( ) where -import SpecUtils +import Ubiq{-uitous-} -import PrelInfo ( liftDataCon, PrimOp(..), PrimRep -- for CCallOp - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import Bag ( emptyBag, unitBag, isEmptyBag, unionBags, + partitionBag, listToBag, bagToList + ) +import Class ( GenClass{-instance Eq-} ) +import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats, + opt_CompilingPrelude, opt_SpecialiseTrace, + opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, + opt_SpecialiseAll ) -import Type -import Bag -import CmdLineOpts ( GlobalSwitch(..) ) import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) -import FiniteMap -import Id -import IdInfo -- All of it -import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) ) -import UniqSet -- All of it -import Util -import UniqSupply +import CoreSyn +import CoreUtils ( coreExprType, squashableDictishCcExpr ) +import FiniteMap ( addListToFM_C ) +import Id ( idType, isDefaultMethodId_maybe, toplevelishId, + isSuperDictSelId_maybe, isBottomingId, + isConstMethodId_maybe, isDataCon, + isImportedId, mkIdWithNewUniq, + dataConTyCon, applyTypeEnvToId, + nullIdEnv, addOneToIdEnv, growIdEnvList, + lookupIdEnv, IdEnv(..), + emptyIdSet, mkIdSet, unitIdSet, + elementOfIdSet, minusIdSet, + unionIdSets, unionManyIdSets, IdSet(..), + GenId{-instance Eq-} + ) +import Literal ( Literal{-instance Outputable-} ) +import Maybes ( catMaybes, firstJust, maybeToBool ) +import Outputable ( interppSP, Outputable(..){-instance * []-} ) +import PprStyle ( PprStyle(..) ) +import PprType ( pprGenType, pprParendGenType, pprMaybeTy, + GenType{-instance Outputable-}, GenTyVar{-ditto-}, + TyCon{-ditto-} + ) +import PrelInfo ( liftDataCon ) +import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, + ppInt, ppSP, ppInterleave, ppNil, Pretty(..) + ) +import PrimOp ( PrimOp(..) ) +import SpecUtils +import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyCon, + tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType + ) +import TyCon ( TyCon{-instance Eq-} ) +import TyVar ( cloneTyVar, + elementOfTyVarSet, TyVarSet(..), + nullTyVarEnv, growTyVarEnvList, TyVarEnv(..), + GenTyVar{-instance Eq-} + ) +import Unique ( Unique{-instance Eq-} ) +import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList ) +import UniqSupply ( splitUniqSupply, getUniques, getUnique ) +import Util ( equivClasses, mapAccumL, assoc, zipWithEqual, + panic, pprTrace, pprPanic, assertPanic + ) infixr 9 `thenSM` + +--ToDo:kill +data SpecInfo = SpecInfo [Maybe Type] Int Id + +addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)" +cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)" +getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)" +isClassOpId = panic "Specialise.isClassOpId (ToDo)" +isDictTy = panic "Specialise.isDictTy (ToDo)" +isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)" +isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)" +isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)" +isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)" +lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)" +lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)" +mkPolySysTyVar = panic "Specialise.mkPolySysTyVar (ToDo)" +mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)" +mkSpecId = panic "Specialise.mkSpecId (ToDo)" +selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)" +specialiseTy = panic "Specialise.specialiseTy (ToDo)" \end{code} %************************************************************************ @@ -614,18 +673,18 @@ strictness analyser deems the lifted binding strict. %************************************************************************ \begin{code} -type FreeVarsSet = UniqSet Id -type FreeTyVarsSet = UniqSet TyVar +type FreeVarsSet = IdSet +type FreeTyVarsSet = TyVarSet data CallInstance = CallInstance - Id -- This Id; *new* ie *cloned* id - [Maybe Type] -- Specialised at these types (*new*, cloned) - -- Nothing => no specialisation on this type arg - -- is required (flag dependent). - [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 + Id -- This Id; *new* ie *cloned* id + [Maybe Type] -- Specialised at these types (*new*, cloned) + -- Nothing => no specialisation on this type arg + -- is required (flag dependent). + [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} \begin{code} @@ -634,14 +693,19 @@ pprCI (CallInstance id spec_tys dicts _ maybe_specinfo) = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id]) 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]), case maybe_specinfo of - Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts]) + Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts]) Just (SpecInfo _ _ spec_id) -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id] ]) +-- ToDo: instance Outputable CoreArg? +ppr_arg sty (TyArg t) = ppr sty t +ppr_arg sty (LitArg i) = ppr sty i +ppr_arg sty (VarArg v) = ppr sty v + isUnboxedCI :: CallInstance -> Bool isUnboxedCI (CallInstance _ spec_tys _ _ _) - = any isUnboxedDataType (catMaybes spec_tys) + = any isUnboxedType (catMaybes spec_tys) isExplicitCI :: CallInstance -> Bool isExplicitCI (CallInstance _ _ _ _ (Just _)) @@ -668,22 +732,22 @@ eqCI_tys c1 c2 isCIofTheseIds :: [Id] -> CallInstance -> Bool isCIofTheseIds ids (CallInstance ci_id _ _ _ _) - = any (eqId ci_id) ids + = any ((==) ci_id) ids singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails singleCI id tys dicts = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing)) - emptyBag [] emptyUniqSet 0 0 + emptyBag [] emptyIdSet 0 0 where - fv_set = mkUniqSet (id : [dict | ValArg (VarArg dict) <- dicts]) + fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts]) explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails explicitCI id tys specinfo - = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet 0 0 + = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0 where call_inst = CallInstance id tys dicts fv_set (Just specinfo) dicts = panic "Specialise:explicitCI:dicts" - fv_set = singletonUniqSet id + fv_set = unitIdSet id -- We do not process the CIs for top-level dfuns or defms -- Instead we require an explicit SPEC inst pragma for dfuns @@ -703,7 +767,9 @@ getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i) cis_here_list = bagToList cis_here in -- pprTrace "getCIs:" - -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"]) + -- (ppHang (ppBesides [ppStr "{", + -- interppSP PprDebug ids, + -- ppStr "}"]) -- 4 (ppAboves (map pprCI cis_here_list))) (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i) @@ -730,7 +796,9 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids then pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++ " (may be a non-HM recursive call)\n") - (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"]) + (ppHang (ppBesides [ppStr "{", + interppSP PprDebug bound_ids, + ppStr "}"]) 4 (ppAboves [ppStr "Dumping CIs:", ppAboves (map pprCI (bagToList cis_of_bound_id)), ppStr "Instantiating CIs:", @@ -741,7 +809,9 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids 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 "{", + interppSP PprDebug full_ids, + ppStr "}"]) 4 (ppAboves (map pprCI (bagToList cis_dump)))) else id) cis_keep_not_bound_id @@ -754,7 +824,7 @@ dumpCIs cis top_lev floating inst_cis bound_ids full_ids = partitionBag ok_to_dump_ci cis_not_bound_id ok_to_dump_ci (CallInstance _ _ _ fv_set _) - = or [i `elementOfUniqSet` fv_set | i <- full_ids] + = any (\ i -> i `elementOfIdSet` fv_set) full_ids (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id have_inst_ci ci = any (eqCI_tys ci) inst_cis @@ -803,10 +873,10 @@ cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails singleTyConI ty_con spec_tys - = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet 0 0 + = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool -isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con +isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con isLocalSpecTyConI :: Bool -> TyConInstance -> Bool isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con @@ -869,22 +939,22 @@ tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i) tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i) = UsageDetails cis ty_cis dbs fvs c (i+1) -emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet 0 0 +emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0 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 `unionIdSets` 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 (VarArg v) | not (isImportedId v) - = UsageDetails emptyBag emptyBag [] (singletonUniqSet v) 0 0 + = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0 singleFvUDs other = emptyUDs -singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con) 0 0 +singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0 dumpDBs :: [DictBindDetails] -> Bool -- True <=> top level bound Ids @@ -911,11 +981,11 @@ dumpDBs [] top_lev bound_tyvars bound_ids fvs 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] - || or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars] + || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids + || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars = let -- Ha! Dump it! (dbinds_here, dbs_outer, full_bound_ids, full_fvs) - = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionUniqSets` fvs) + = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs) in (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs) @@ -943,7 +1013,7 @@ dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound (dict_binds_here, dbs_outer, full_bound_ids, full_fvs) = dumpDBs dbs top_lev tvs bound_ids fvs cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids - fvs_outer = full_fvs `minusUniqSet` (mkUniqSet full_bound_ids) + fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids) in (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i) \end{code} @@ -1057,23 +1127,22 @@ ToDo[sansom]: Transformation data to process specialisation requests. %************************************************************************ \begin{code} -specProgram :: (GlobalSwitch -> Bool) - -> UniqSupply +specProgram :: UniqSupply -> [CoreBinding] -- input ... -> SpecialiseData -> ([CoreBinding], -- main result SpecialiseData) -- result specialise data -specProgram sw_chker uniqs binds +specProgram uniqs binds (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs) - = case (initSM (specTyConsAndScope (specTopBinds binds)) sw_chker uniqs) of + = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of (final_binds, tycon_specs_list, UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts) -> let used_conids = filter isDataCon (uniqSetToList fvs) - used_tycons = map getDataConTyCon used_conids + used_tycons = map dataConTyCon used_conids used_gen = filter isLocalGenTyCon used_tycons - gen_tycons = setToList (mkSet local_tycons `union` mkSet used_gen) + gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen) result_specs = addListToFM_C (++) init_specs tycon_specs_list @@ -1088,9 +1157,9 @@ specProgram sw_chker uniqs binds tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs - && (not (sw_chker SpecialiseImports) || isEmptyBag cis_warn) + && (not opt_SpecialiseImports || isEmptyBag cis_warn) in - (if sw_chker D_simplifier_stats then + (if opt_D_simplifier_stats then pprTrace "\nSpecialiser Stats:\n" (ppAboves [ ppBesides [ppStr "SpecCalls ", ppInt spec_calls], ppBesides [ppStr "SpecInsts ", ppInt spec_insts], @@ -1101,7 +1170,7 @@ specProgram sw_chker uniqs binds SpecData True no_errs local_tycons gen_tycons result_specs cis_errs cis_warn tycis_errs) -specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _) +specProgram uniqs binds (SpecData True _ _ _ _ _ _ _) = panic "Specialise:specProgram: specialiser called more than once" -- It may be possible safely to call the specialiser more than once, @@ -1128,14 +1197,13 @@ specTyConsAndScope :: SpecM ([CoreBinding], 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 opt_CompilingPrelude scope_uds tycon_specs_list = collectTyConSpecs tycons_cis in - (if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then + (if opt_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"]) @@ -1180,8 +1248,8 @@ specTopBinds binds (dbinders_s, dbinds, dfvs_s) = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details] - full_fvs = fvs `unionUniqSets` unionManyUniqSets dfvs_s - fvs_outer = full_fvs `minusUniqSet` (mkUniqSet (concat dbinders_s)) + full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s + fvs_outer = full_fvs `minusIdSet` (mkIdSet (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* Rec and @@ -1211,11 +1279,11 @@ specTopBinds binds \begin{code} specExpr :: CoreExpr -> [CoreArg] -- The arguments: - -- TypeArgs are speced - -- ValArgs are unprocessed + -- TypeArgs are speced + -- ValArgs are unprocessed -> SpecM (CoreExpr, -- Result expression with specialised versions installed - UsageDetails) -- Details of usage of enclosing binders in the result - -- expression. + UsageDetails)-- Details of usage of enclosing binders in the result + -- expression. specExpr (Var v) args = lookupId v `thenSM` \ vlookup -> @@ -1228,7 +1296,7 @@ specExpr (Var v) args returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl)) NoLift vatom@(VarArg new_v) - -> mapSM specArg args `thenSM` \ arg_info -> + -> mapSM specOutArg args `thenSM` \ arg_info -> mkCallInstance v new_v arg_info `thenSM` \ call_uds -> mkCall new_v arg_info `thenSM` \ ~(speced, call) -> let @@ -1243,29 +1311,38 @@ specExpr expr@(Lit _) null_args = ASSERT (null null_args) returnSM (expr, emptyUDs) -specExpr (Con con tys args) null_args +specExpr (Con con 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 (Con con tys args), + let + (targs, vargs) = partition_args args + in + mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) -> + mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) -> + mkTyConInstance con tys `thenSM` \ con_uds -> + returnSM (applyBindUnlifts unlifts (Con con (targs ++ vargs)), unionUDList args_uds_s `unionUDs` con_uds) -specExpr (Prim 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) 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 (Prim (CCallOp str is_asm may_gc arg_tys res_ty) tys args), + let + (targs, vargs) = partition_args args + in + ASSERT (null targs) + mapSM specTy arg_tys `thenSM` \ arg_tys -> + specTy res_ty `thenSM` \ res_ty -> + mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) -> + returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) vargs), unionUDList args_uds_s) -specExpr (Prim prim tys args) null_args +specExpr (Prim prim args) null_args = ASSERT (null null_args) - mapSM specTy tys `thenSM` \ tys -> - mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) -> + let + (targs, vargs) = partition_args args + in + mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) -> + mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) -> -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) -> - returnSM (applyBindUnlifts unlifts (Prim prim tys args), + returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)), unionUDList args_uds_s {-`unionUDs` prim_uds-} ) {- ToDo: specPrimOp @@ -1286,33 +1363,27 @@ specPrimOp :: PrimOp specExpr (App fun arg) args - = -- Arg is passed on unprocessed - specExpr fun (ValArg arg : args) `thenSM` \ (expr,uds) -> + = -- If TyArg, arg will be processed; otherwise, left alone + preSpecArg arg `thenSM` \ new_arg -> + specExpr fun (new_arg : args) `thenSM` \ (expr,uds) -> returnSM (expr, uds) -specExpr (CoTyApp fun ty) args - = -- Spec the tyarg and pass it on - specTy ty `thenSM` \ ty -> - specExpr fun (TypeArg ty : args) - -specExpr (Lam binder body) (ValArg arg : args) +specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg = 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) [] +specExpr (Lam (ValBinder binder) body) [] = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) -> - returnSM (Lam binder body, uds) + returnSM (Lam (ValBinder binder) body, uds) -specExpr (CoTyLam tyvar body) (TypeArg ty : args) +specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args) = -- Type lambda with argument; argument already spec'd - bindTyVar tyvar ty ( - specExpr body args - ) + bindTyVar tyvar ty ( specExpr body args ) -specExpr (CoTyLam tyvar body) [] +specExpr (Lam (TyBinder tyvar) body) [] = -- No arguments cloneTyVarSM tyvar `thenSM` \ new_tyvar -> bindTyVar tyvar (mkTyVarTy new_tyvar) ( @@ -1320,7 +1391,9 @@ specExpr (CoTyLam tyvar body) [] let (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar] in - returnSM (CoTyLam new_tyvar (mkCoLetsNoUnboxed binds_here body), final_uds) + returnSM (Lam (TyBinder new_tyvar) + (mkCoLetsNoUnboxed binds_here body), + final_uds) ) specExpr (Case scrutinee alts) args @@ -1330,7 +1403,6 @@ specExpr (Case scrutinee alts) args where scrutinee_type = coreExprType scrutinee - specExpr (Let bind body) args = specBindAndScope False bind ( specExpr body args `thenSM` \ (body, body_uds) -> @@ -1339,8 +1411,8 @@ specExpr (Let bind body) args returnSM (mkCoLetsUnboxedToCase binds body, all_uds) specExpr (SCC cc expr) args - = specExpr expr [] `thenSM` \ (expr, expr_uds) -> - mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) -> + = specExpr expr [] `thenSM` \ (expr, expr_uds) -> + mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) -> let scc_expr = if squashableDictishCcExpr cc expr -- can toss the _scc_ @@ -1420,7 +1492,6 @@ Now we must specialise op1 at {* Int#} which requires a version of meth1 at {Int#}. But since meth1 was extracted from a dictionary we do not have access to its code to create the specialised version. - If we specialise on overloaded types as well we specialise op1 at {Int Int#} d.Foo.Int: @@ -1455,9 +1526,10 @@ specAlts (AlgAlts alts deflt) scrutinee_ty args specDeflt deflt args `thenSM` \ (deflt, deflt_uds) -> returnSM (AlgAlts alts deflt, unionUDList alts_uds_s `unionUDs` deflt_uds) - where - -- We use ty_args of scrutinee type to identify specialisation of alternatives + -- We use ty_args of scrutinee type to identify specialisation of + -- alternatives: + (_, ty_args, _) = getAppDataTyCon scrutinee_ty specAlgAlt ty_args (con,binders,rhs) @@ -1489,13 +1561,30 @@ specDeflt (BindDefault binder rhs) args %************************************************************************ \begin{code} -specAtom :: CoreArg -> SpecM (CoreArg, UsageDetails, - CoreExpr -> CoreExpr) +partition_args :: [CoreArg] -> ([CoreArg], [CoreArg]) +partition_args args + = span is_ty_arg args + where + is_ty_arg (TyArg _) = True + is_ty_arg _ = False + +---------- +preSpecArg :: CoreArg -> SpecM CoreArg -- diddle TyArgs, but nothing else -specAtom (LitArg lit) +preSpecArg (TyArg ty) + = specTy ty `thenSM` \ new_ty -> + returnSM (TyArg new_ty) + +preSpecArg other = returnSM other + +-------------------- +specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails, + CoreExpr -> CoreExpr) + +specValArg (LitArg lit) = returnSM (LitArg lit, emptyUDs, id) -specAtom (VarArg v) +specValArg (VarArg v) = lookupId v `thenSM` \ vlookup -> case vlookup of Lifted vl vu @@ -1505,15 +1594,20 @@ specAtom (VarArg v) -> returnSM (vatom, singleFvUDs vatom, id) -specArg :: CoreArg -> SpecM (CoreArg, UsageDetails, +------------------ +specTyArg (TyArg ty) + = specTy ty `thenSM` \ new_ty -> + returnSM (TyArg new_ty, new_ty) + +-------------- +specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails, CoreExpr -> CoreExpr) -specArg (ValArg arg) -- unprocessed; spec the atom - = specAtom arg `thenSM` \ (arg, uds, unlift) -> - returnSM (ValArg arg, uds, unlift) +specOutArg (TyArg ty) -- already speced; no action + = returnSM (TyArg ty, emptyUDs, id) -specArg (TypeArg ty) -- already speced; no action - = returnSM (TypeArg ty, emptyUDs, id) +specOutArg other_arg -- unprocessed; spec the atom + = specValArg other_arg \end{code} @@ -1744,14 +1838,16 @@ instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis else if top_lev 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 (pprType PprDebug . idType) new_ids), + ) (ppHang (ppBesides [ppStr "{", + interppSP PprDebug new_ids, + ppStr "}"]) + 4 (ppAboves [ppAboves (map (pprGenType PprDebug . idType) new_ids), ppAboves (map pprCI (concat equiv_ciss))])) (returnSM ([], emptyUDs, [])) where (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder - tyvar_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls + tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls no_of_tyvars = length tyvar_tmpls no_of_dicts = length class_tyvar_pairs @@ -1841,8 +1937,7 @@ mkOneInst :: CallInstance mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind - = getSwitchCheckerSM `thenSM` \ sw_chkr -> - newSpecIds new_ids spec_tys no_of_dicts_to_specialise + = newSpecIds new_ids spec_tys no_of_dicts_to_specialise `thenSM` \ spec_ids -> newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars -> let @@ -1852,7 +1947,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys args :: [CoreArg] - args = map TypeArg arg_tys ++ dict_args + args = map TyArg arg_tys ++ dict_args (new_id:_) = new_ids (spec_id:_) = spec_ids @@ -1877,7 +1972,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis -- a specialised instance has been created but specialisation -- "required" by one of the other Ids in the Rec | top_lev && maybeToBool lookup_orig_spec - = (if sw_chkr SpecialiseTrace + = (if opt_SpecialiseTrace then trace_nospec " Exists: " exists_id else id) ( @@ -1887,7 +1982,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis -- Check for a (single) explicit call instance for this id | not (null explicit_cis_for_this_id) = ASSERT (length explicit_cis_for_this_id == 1) - (if sw_chkr SpecialiseTrace + (if opt_SpecialiseTrace then trace_nospec " Explicit: " explicit_id else id) ( @@ -1912,7 +2007,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id) in - if isUnboxedDataType (idType spec_id) then + if isUnboxedType (idType spec_id) then ASSERT (null poly_tyvars) liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) -> mkTyConInstance liftDataCon [idType unlift_spec_id] @@ -1922,7 +2017,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info) else returnSM (Just (spec_id, - mkCoLetsNoUnboxed local_dict_binds (mkCoTyLam poly_tyvars inst_rhs)), + mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)), tickSpecInsts final_uds, spec_info) where lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys @@ -1932,14 +2027,17 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id SpecInfo _ _ explicit_id = explicit_spec_info + trace_nospec :: String -> Id -> a -> a trace_nospec str spec_id = pprTrace str (ppCat [ppr PprDebug new_id, ppInterleave ppNil (map pp_ty arg_tys), ppStr "==>", ppr PprDebug spec_id]) in - (if sw_chkr SpecialiseTrace then + (if opt_SpecialiseTrace then pprTrace "Specialising:" - (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"]) + (ppHang (ppBesides [ppStr "{", + interppSP PprDebug new_ids, + ppStr "}"]) 4 (ppAboves [ ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)], if isExplicitCI do_cis then ppNil else @@ -1952,8 +2050,8 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis returnSM (maybe_inst_bind, inst_uds, spec_infos) ) where - pp_dict (ValArg d) = ppr PprDebug d - pp_ty t = pprParendType PprDebug t + pp_dict d = ppr_arg PprDebug d + pp_ty t = pprParendGenType PprDebug t do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar) do_the_wotsit tyvars (Just ty) = (tyvars, ty) @@ -1994,11 +2092,10 @@ mkCallInstance id new_id args -- instances for a ConstMethodId extracted from its SpecEnv | otherwise - = getSwitchCheckerSM `thenSM` \ sw_chkr -> - let - spec_overloading = sw_chkr SpecialiseOverloaded - spec_unboxed = sw_chkr SpecialiseUnboxed - spec_all = sw_chkr SpecialiseAll + = let + spec_overloading = opt_SpecialiseOverloaded + spec_unboxed = opt_SpecialiseUnboxed + spec_all = opt_SpecialiseAll (tyvars, class_tyvar_pairs) = getIdOverloading id @@ -2019,7 +2116,7 @@ mkCallInstance id new_id args 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 : map (ppr_arg PprDebug) [arg | (arg,_,_) <- args])) else case record_spec id tys of (False, _, _) @@ -2075,25 +2172,26 @@ mkCallInstance id new_id args (returnSM emptyUDs) -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 (_:tyvars) class_tyvar_pairs ((TyArg 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 - = 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) - = case take_dict_args class_tyvar_pairs args of - Nothing -> Nothing - Just (dicts, others) -> Just (dict:dicts, others) -take_dict_args (_:class_tyvar_pairs) [] - = Nothing -take_dict_args [] args - = Just ([], 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,_,_):args) | isValArg dict + = case (take_dict_args class_tyvar_pairs args) of + Nothing -> Nothing + Just (dicts, others) -> Just (dict:dicts, others) + +take_dict_args (_:class_tyvar_pairs) [] = Nothing + +take_dict_args [] args = Just ([], args) \end{code} \begin{code} @@ -2103,7 +2201,7 @@ mkCall :: Id mkCall new_id args | maybeToBool (isSuperDictSelId_maybe new_id) - && any isUnboxedDataType ty_args + && any isUnboxedType ty_args -- No specialisations for super-dict selectors -- Specialise unboxed calls to SuperDictSelIds by extracting -- the super class dictionary directly form the super class @@ -2149,7 +2247,7 @@ mkCall new_id args -- These top level defns should have been lifted. -- We must add code to unlift such a spec_id. - if isUnboxedDataType (idType spec_id) then + if isUnboxedType (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) -> @@ -2158,13 +2256,13 @@ mkCall new_id args else pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n" (ppCat [ppr PprDebug new_id, - ppInterleave ppNil (map (pprParendType PprDebug) ty_args), + ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args), ppStr "==>", ppr PprDebug spec_id]) else let (vals_left, _, unlifts_left) = unzip3 args_left - applied_tys = mkCoTyApps (Var spec_id) tys_left + applied_tys = mkTyApp (Var spec_id) tys_left applied_vals = mkGenApp applied_tys vals_left in returnSM (True, applyBindUnlifts unlifts_left applied_vals) @@ -2179,33 +2277,34 @@ mkCall new_id args (ty_args, val_args) = get args where - get ((TypeArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args - get args = ([], args) + get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args + get args = ([], args) -- toss_dicts chucks away dict args, checking that they ain't types! - toss_dicts 0 args = args - toss_dicts n ((ValArg _,_,_) : args) = toss_dicts (n-1) args + toss_dicts 0 args = args + toss_dicts n ((a,_,_) : args) + | isValArg a = toss_dicts (n-1) args \end{code} \begin{code} checkUnspecOK :: Id -> [Type] -> a -> a checkUnspecOK check_id tys - = if isLocallyDefined check_id && any isUnboxedDataType tys + = if isLocallyDefined check_id && any isUnboxedType tys then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n" (ppCat [ppr PprDebug check_id, - ppInterleave ppNil (map (pprParendType PprDebug) tys)]) + ppInterleave ppNil (map (pprParendGenType PprDebug) tys)]) else id checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a checkSpecOK check_id tys spec_id tys_left - = if any isUnboxedDataType tys_left + = if any isUnboxedType tys_left then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n" (ppAboves [ppCat [ppr PprDebug check_id, - ppInterleave ppNil (map (pprParendType PprDebug) tys)], + ppInterleave ppNil (map (pprParendGenType PprDebug) tys)], ppCat [ppr PprDebug spec_id, - ppInterleave ppNil (map (pprParendType PprDebug) tys_left)]]) + ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]]) else id \end{code} @@ -2231,7 +2330,7 @@ mkTyConInstance con tys -- ppStr ")"]]) (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con)) where - tycon = getDataConTyCon con + tycon = dataConTyCon con \end{code} \begin{code} @@ -2274,35 +2373,32 @@ Monad has: threaded in and out: unique supply \begin{code} +type TypeEnv = TyVarEnv Type + type SpecM result - = (GlobalSwitch -> Bool) - -> TypeEnv + = TypeEnv -> SpecIdEnv -> UniqSupply -> result -initSM m sw_chker uniqs - = m sw_chker nullTyVarEnv nullIdEnv uniqs +initSM m uniqs + = m nullTyVarEnv nullIdEnv uniqs returnSM :: a -> SpecM a thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b fixSM :: (a -> SpecM a) -> SpecM a -thenSM m k sw_chkr tvenv idenv us +thenSM m k tvenv idenv us = case splitUniqSupply us of { (s1, s2) -> - case (m sw_chkr tvenv idenv s1) of { r -> - k r sw_chkr tvenv idenv s2 }} + case (m tvenv idenv s1) of { r -> + k r tvenv idenv s2 }} -returnSM r sw_chkr tvenv idenv us = r +returnSM r tvenv idenv us = r -fixSM k sw_chkr tvenv idenv us +fixSM k tvenv idenv us = r where - r = k r sw_chkr tvenv idenv us -- Recursive in r! -\end{code} - -\begin{code} -getSwitchCheckerSM sw_chkr tvenv idenv us = sw_chkr + r = k r tvenv idenv us -- Recursive in r! \end{code} The only interesting bit is figuring out the type of the SpecId! @@ -2313,7 +2409,7 @@ newSpecIds :: [Id] -- The id of which to make a specialised version -> Int -- No of dicts to specialise -> SpecM [Id] -newSpecIds new_ids maybe_tys dicts_to_ignore sw_chkr tvenv idenv us +newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id) | (id,uniq) <- new_ids `zip` uniqs ] where @@ -2321,7 +2417,7 @@ newSpecIds new_ids maybe_tys dicts_to_ignore sw_chkr tvenv idenv us spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore newTyVars :: Int -> SpecM [TyVar] -newTyVars n sw_chkr tvenv idenv us +newTyVars n tvenv idenv us = map mkPolySysTyVar uniqs where uniqs = getUniques n us @@ -2343,7 +2439,7 @@ As well as returning the list of cloned @Id@s they also return a list of cloneLambdaOrCaseBinders :: [Id] -- Old binders -> SpecM ([Id], [CloneInfo]) -- New ones -cloneLambdaOrCaseBinders old_ids sw_chkr tvenv idenv us +cloneLambdaOrCaseBinders old_ids tvenv idenv us = let uniqs = getUniques (length old_ids) us in @@ -2359,7 +2455,7 @@ cloneLetBinders :: Bool -- Top level ? -> [Id] -- Old binders -> SpecM ([Id], [CloneInfo]) -- New ones -cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us +cloneLetBinders top_lev is_rec old_ids tvenv idenv us = let uniqs = getUniques (2 * length old_ids) us in @@ -2379,7 +2475,7 @@ cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us -- (c) the thing is polymorphic so no need to subst | otherwise - = if (is_rec && isUnboxedDataType new_ty && not (isUnboxedDataType old_ty)) + = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty)) then (lifted_id, Lifted lifted_id unlifted_id) : clone_rest else (new_id, @@ -2397,7 +2493,7 @@ cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us cloneTyVarSM :: TyVar -> SpecM TyVar -cloneTyVarSM old_tyvar sw_chkr tvenv idenv us +cloneTyVarSM old_tyvar tvenv idenv us = let uniq = getUnique us in @@ -2405,13 +2501,13 @@ cloneTyVarSM old_tyvar sw_chkr tvenv idenv us bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing -bindId id val specm sw_chkr tvenv idenv us - = specm sw_chkr tvenv (addOneToIdEnv idenv id val) us +bindId id val specm tvenv idenv us + = specm tvenv (addOneToIdEnv idenv id val) us bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing -bindIds olds news specm sw_chkr tvenv idenv us - = specm sw_chkr tvenv (growIdEnvList idenv (zip olds news)) us +bindIds olds news specm tvenv idenv us + = specm tvenv (growIdEnvList idenv (zip olds news)) us bindSpecIds :: [Id] -- Old -> [(CloneInfo)] -- New @@ -2421,8 +2517,8 @@ bindSpecIds :: [Id] -- Old -> SpecM thing -> SpecM thing -bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us - = specm sw_chkr tvenv (growIdEnvList idenv old_to_clone) us +bindSpecIds olds clones spec_infos specm tvenv idenv us + = specm tvenv (growIdEnvList idenv old_to_clone) us where old_to_clone = mk_old_to_clone olds clones spec_infos @@ -2444,14 +2540,14 @@ bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us 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 +bindTyVar tyvar ty specm tvenv idenv us + = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us \end{code} \begin{code} lookupId :: Id -> SpecM CloneInfo -lookupId id sw_chkr tvenv idenv us +lookupId id tvenv idenv us = case lookupIdEnv idenv id of Nothing -> NoLift (VarArg id) Just info -> info @@ -2460,13 +2556,13 @@ lookupId id sw_chkr tvenv idenv us \begin{code} specTy :: Type -> SpecM Type -- Apply the current type envt to the type -specTy ty sw_chkr tvenv idenv us +specTy ty tvenv idenv us = applyTypeEnvToTy tvenv ty \end{code} \begin{code} liftId :: Id -> SpecM (Id, Id) -liftId id sw_chkr tvenv idenv us +liftId id tvenv idenv us = let uniq = getUnique us in diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 5afb086..50a9bc0 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -13,39 +13,35 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program. \begin{code} #include "HsVersions.h" -module CoreToStg ( - topCoreBindsToStg +module CoreToStg ( topCoreBindsToStg ) where - -- and to make the interface self-sufficient... - ) where +import Ubiq{-uitous-} -import AnnCoreSyn -- intermediate form on which all work is done +import CoreSyn -- input import StgSyn -- output -import UniqSupply +import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList ) +import CoreUtils ( coreExprType ) +import CostCentre ( noCostCentre ) +import Id ( mkSysLocal, idType, isBottomingId, + nullIdEnv, addOneToIdEnv, lookupIdEnv, + IdEnv(..), GenId{-instance NamedThing-} + ) +import Literal ( mkMachInt, Literal(..) ) +import Outputable ( isExported ) import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy, integerTy, rationalTy, ratioDataCon, - PrimOp(..), -- For Int2IntegerOp etc integerZeroId, integerPlusOneId, integerPlusTwoId, integerMinusOneId - IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) - -import Type ( isPrimType, isLeakFreeType, getAppDataTyCon ) -import Bag -- Bag operations -import Literal ( mkMachInt, Literal(..) ) -- ToDo: its use is ugly... -import CostCentre ( noCostCentre, CostCentre ) -import Id ( mkSysLocal, idType, isBottomingId - IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) ) -import Maybes ( Maybe(..), catMaybes ) -import Outputable ( isExported ) -import Pretty -- debugging only! +import PrimOp ( PrimOp(..) ) import SpecUtils ( mkSpecialisedCon ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) -import Util +import SrcLoc ( mkUnknownSrcLoc ) +import Type ( getAppDataTyCon ) +import UniqSupply -- all of it, really +import Util ( panic ) + +isLeakFreeType = panic "CoreToStg.isLeakFreeType (ToDo)" \end{code} @@ -360,10 +356,20 @@ litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag) %************************************************************************ \begin{code} -coreAtomToStg :: StgEnv -> CoreArg -> UniqSM (StgArg, Bag StgBinding) +coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding) -coreAtomToStg env (VarArg var) = returnUs (stgLookup env var, emptyBag) -coreAtomToStg env (LitArg lit) = litToStgArg lit +coreArgsToStg env [] = returnUs ([], [], emptyBag) +coreArgsToStg env (a:as) + = coreArgsToStg env as `thenUs` \ (tys, args, binds) -> + do_arg a tys args binds + where + do_arg a trest vrest binds + = case a of + TyArg t -> returnUs (t:trest, vrest, binds) + UsageArg u -> returnUs (trest, vrest, binds) + VarArg v -> returnUs (trest, stgLookup env v : vrest, binds) + LitArg i -> litToStgArg i `thenUs` \ (v, bs) -> + returnUs (trest, v:vrest, bs `unionBags` binds) \end{code} There's not anything interesting we can ASSERT about \tr{var} if it @@ -397,28 +403,16 @@ coreExprToStg env (Lit lit) coreExprToStg env (Var var) = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) -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 (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} - -%************************************************************************ -%* * -\subsubsection[coreToStg-type-stuff]{Type application and abstraction} -%* * -%************************************************************************ - -This type information dies in this Core-to-STG translation. +coreExprToStg env (Con con args) + = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) -> + let + spec_con = mkSpecialisedCon con types + in + returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds) -\begin{code} -coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr -coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr +coreExprToStg env (Prim op args) + = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) -> + returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds) \end{code} %************************************************************************ @@ -429,7 +423,10 @@ coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr \begin{code} coreExprToStg env expr@(Lam _ _) - = coreExprToStg env body `thenUs` \ (stg_body, binds) -> + = let + (_,_, binders, body) = collectBinders expr + in + coreExprToStg env body `thenUs` \ (stg_body, binds) -> newStgVar (coreExprType expr) `thenUs` \ var -> returnUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre @@ -440,14 +437,6 @@ coreExprToStg env expr@(Lam _ _) 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} %************************************************************************ @@ -458,13 +447,15 @@ coreExprToStg env expr@(Lam _ _) \begin{code} coreExprToStg env expr@(App _ _) - = -- Deal with the arguments - mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_args, arg_binds) -> + = let + (fun, _, _, args) = collectArgs expr + in + -- Deal with the arguments + coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) -> -- Now deal with the function case fun of - Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, - unionManyBags arg_binds) + Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds) other -> -- A non-variable applied to things; better let-bind it. newStgVar (coreExprType fun) `thenUs` \ fun_id -> @@ -479,16 +470,7 @@ coreExprToStg env expr@(App _ _) in 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 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) + arg_binds `unionBags` fun_binds) \end{code} %************************************************************************ @@ -517,9 +499,9 @@ to \begin{code} -coreExprToStg env (Case discrim@(Prim op tys args) alts) - | funnyParallelOp op = - getUnique `thenUs` \ uniq -> +coreExprToStg env (Case discrim@(Prim op _) alts) + | funnyParallelOp op + = getUnique `thenUs` \ uniq -> coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) -> alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> returnUs ( diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index b97ef11..74abea7 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[StgLint]{A ``lint'' pass to check for Stg correctness} @@ -8,25 +8,34 @@ module StgLint ( lintStgBindings ) where -import PrelInfo ( primOpType, mkFunTy, PrimOp(..), PrimRep - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import Type -import Bag -import Literal ( literalType, Literal ) +import Ubiq{-uitous-} + +import StgSyn + +import Bag ( emptyBag, isEmptyBag, snocBag, foldBag ) import Id ( idType, isDataCon, - getInstantiatedDataConSig + emptyIdSet, isEmptyIdSet, elementOfIdSet, + mkIdSet, intersectIdSets, + unionIdSets, idSetToList, IdSet(..), + GenId{-instanced NamedThing-} ) -import Maybes -import Outputable -import Pretty -import SrcLoc ( SrcLoc ) -import StgSyn -import UniqSet -import Util +import Literal ( literalType, Literal{-instance Outputable-} ) +import Maybes ( catMaybes ) +import Outputable ( Outputable(..){-instance * []-} ) +import PprType ( GenType{-instance Outputable-}, TyCon ) +import Pretty -- quite a bit of it +import PrimOp ( primOpType ) +import SrcLoc ( SrcLoc{-instance Outputable-} ) +import Type ( mkFunTys, splitFunTy, maybeAppDataTyCon, + isTyVarTy, eqTy + ) +import Util ( zipEqual, pprPanic, panic, panic# ) infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` + +getInstantiatedDataConSig = panic "StgLint.getInstantiatedDataConSig (ToDo)" +splitTypeWithDictsAsArgs = panic "StgLint.splitTypeWithDictsAsArgs (ToDo)" +unDictifyTy = panic "StgLint.unDictifyTy (ToDo)" \end{code} Checks for @@ -114,7 +123,7 @@ lintStgRhs (StgRhsClosure _ _ _ _ binders expr) = addLoc (LambdaBodyOf binders) ( addInScopeVars binders ( lintStgExpr expr `thenMaybeL` \ body_ty -> - returnL (Just (foldr (mkFunTy . idType) body_ty binders)) + returnL (Just (mkFunTys (map idType binders) body_ty)) )) lintStgRhs (StgRhsCon _ con args) @@ -193,7 +202,6 @@ lintStgAlts :: StgCaseAlts lintStgAlts alts scrut_ty case_tycon = (case alts of 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) @@ -211,11 +219,6 @@ lintStgAlts alts scrut_ty case_tycon returnL (Just first_ty) where check ty = checkTys first_ty ty (mkCaseAltMsg alts) - where - chk_non_abstract_type tycon - = case (getTyConFamilySize tycon) of - Nothing -> addErrL (mkCaseAbstractMsg tycon) - Just _ -> returnL () -- that's cool lintAlgAlt scrut_ty (con, args, _, rhs) = (case maybeAppDataTyCon scrut_ty of @@ -264,7 +267,7 @@ lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty \begin{code} type LintM a = [LintLocInfo] -- Locations - -> UniqSet Id -- Local vars in scope + -> IdSet -- Local vars in scope -> Bag ErrMsg -- Error messages so far -> (a, Bag ErrMsg) -- Result and error messages (if any) @@ -298,12 +301,12 @@ pp_binders sty bs \begin{code} initL :: LintM a -> Maybe ErrMsg initL m - = case (m [] emptyUniqSet emptyBag) of { (_, errs) -> + = case (m [] emptyIdSet emptyBag) of { (_, errs) -> if isEmptyBag errs then Nothing else Just ( \ sty -> - ppAboves [ msg sty | msg <- bagToList errs ] + foldBag ppAbove ( \ msg -> msg sty ) ppNil errs ) } @@ -374,17 +377,16 @@ addInScopeVars ids m loc scope errs -- For now, it's just a "trace"; we may make -- a real error out of it... let - new_set = mkUniqSet ids + new_set = mkIdSet ids - shadowed = scope `intersectUniqSets` new_set + shadowed = scope `intersectIdSets` new_set in -- After adding -fliberate-case, Simon decided he likes shadowed -- names after all. WDP 94/07 --- (if isEmptyUniqSet shadowed +-- (if isEmptyIdSet shadowed -- then id --- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) ( - m loc (scope `unionUniqSets` new_set) errs --- ) +-- else pprTrace "Shadowed vars:" (ppr PprDebug (idSetToList shadowed))) $ + m loc (scope `unionIdSets` new_set) errs \end{code} \begin{code} @@ -399,38 +401,38 @@ checkFunApp fun_ty arg_tys msg loc scope errs (_, expected_arg_tys, res_ty) = splitTypeWithDictsAsArgs fun_ty cfa res_ty expected [] -- Args have run out; that's fine - = (Just (glueTyArgs expected res_ty), errs) + = (Just (mkFunTys expected res_ty), errs) 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 -- dictionary type which is actually a function? - | isTyVarTemplateTy res_ty + | isTyVarTy res_ty = (Just res_ty, errs) | otherwise - = case splitTyArgs (unDictifyTy res_ty) of + = case splitFunTy (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 (sleazy_cmp_ty expected_arg_ty arg_ty) of - EQ_ -> cfa res_ty expected_arg_tys arg_tys - _ -> (Nothing, addErr errs msg loc) -- Arg mis-match + = if (sleazy_eq_ty expected_arg_ty arg_ty) + then cfa res_ty expected_arg_tys arg_tys + else (Nothing, addErr errs msg loc) -- Arg mis-match \end{code} \begin{code} checkInScope :: Id -> LintM () checkInScope id loc scope errs - = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfUniqSet` scope) then + = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfIdSet` scope) then ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc) else ((), errs) checkTys :: Type -> Type -> ErrMsg -> LintM () checkTys ty1 ty2 msg loc scope errs - = case (sleazy_cmp_ty ty1 ty2) of - EQ_ -> ((), errs) - other -> ((), addErr errs msg loc) + = if (sleazy_eq_ty ty1 ty2) + then ((), errs) + else ((), addErr errs msg loc) \end{code} \begin{code} @@ -520,14 +522,15 @@ mkRhsMsg binder ty sty pp_expr :: PprStyle -> StgExpr -> Pretty pp_expr sty expr = ppr sty expr -sleazy_cmp_ty ty1 ty2 +sleazy_eq_ty ty1 ty2 -- NB: probably severe overkill (WDP 95/04) = case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) -> case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) -> let - ty11 = glueTyArgs tyargs1 tyres1 - ty22 = glueTyArgs tyargs2 tyres2 + ty11 = mkFunTys tyargs1 tyres1 + ty22 = mkFunTys tyargs2 tyres2 in - cmpUniType False{-!!!NOT PROPERLY!!!-} ty11 ty22 + trace "StgLint.sleazy_cmp_ty" $ + ty11 `eqTy` ty22 }} \end{code} diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 456a7f8..395eaa0 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -41,27 +41,20 @@ module StgSyn ( import Ubiq{-uitous-} -{- -import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..), - PrimOp, PrimRep - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import CostCentre ( showCostCentre ) +import Id ( idPrimRep, GenId{-instance NamedThing-} ) +import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} ) +import Outputable ( isExported, isOpLexeme, ifPprDebug, + interppSP, interpp'SP, + Outputable(..){-instance * Bool-} ) -import HsSyn ( HsBinds, HsExpr, GRHS, GRHSsAndBinds, InPat ) -import Type -import Literal ( literalPrimRep, isLitLitLit, - Literal(..) -- (..) for pragmas - ) -import Id ( idType, getIdPrimRep, toplevelishId, - isTopLevId, Id, IdInfo - ) -import Maybes ( Maybe(..), catMaybes ) -import Outputable -import Pretty -import CostCentre ( showCostCentre, CostCentre ) -import UniqSet -import Util --} +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-} ) +import Pretty -- all of it +import PrimOp ( PrimOp{-instance Outputable-} ) +import Unique ( pprUnique ) +import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet(..) ) +import Util ( panic ) \end{code} %************************************************************************ @@ -94,8 +87,8 @@ data GenStgArg occ \end{code} \begin{code} -getArgPrimRep (StgVarArg local) = getIdPrimRep local -getArgPrimRep (StgLitArg lit) = literalPrimRep lit +getArgPrimRep (StgVarArg local) = idPrimRep local +getArgPrimRep (StgLitArg lit) = literalPrimRep lit isLitLitArg (StgLitArg x) = isLitLitLit x isLitLitArg _ = False diff --git a/ghc/compiler/stgSyn/StgUtils.lhs b/ghc/compiler/stgSyn/StgUtils.lhs index 830a752..7c89ac3 100644 --- a/ghc/compiler/stgSyn/StgUtils.lhs +++ b/ghc/compiler/stgSyn/StgUtils.lhs @@ -1,5 +1,5 @@ x% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[StgUtils]{Utility functions for @STG@ programs} @@ -8,11 +8,11 @@ x% module StgUtils ( mapStgBindeesRhs ) where -import StgSyn +import Ubiq{-uitous-} +import Id ( GenId{-instanced NamedThing-} ) +import StgSyn import UniqSet - -import Util \end{code} This utility function simply applies the given function to every @@ -36,21 +36,21 @@ mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr) (mapStgBindeesExpr fn expr) mapStgBindeesRhs fn (StgRhsCon cc con atoms) - = StgRhsCon cc con (map (mapStgBindeesAtom fn) atoms) + = StgRhsCon cc con (map (mapStgBindeesArg fn) atoms) ------------------ mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr mapStgBindeesExpr fn (StgApp f args lvs) - = StgApp (mapStgBindeesAtom fn f) - (map (mapStgBindeesAtom fn) args) + = StgApp (mapStgBindeesArg fn f) + (map (mapStgBindeesArg fn) args) (mapUniqSet fn lvs) mapStgBindeesExpr fn (StgCon con atoms lvs) - = StgCon con (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs) + = StgCon con (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs) mapStgBindeesExpr fn (StgPrim op atoms lvs) - = StgPrim op (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs) + = StgPrim op (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs) mapStgBindeesExpr fn (StgLet bind expr) = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr) @@ -83,8 +83,8 @@ mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts) mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr) ------------------ -mapStgBindeesAtom :: (Id -> Id) -> StgArg -> StgArg +mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg -mapStgBindeesAtom fn a@(StgLitArg _) = a -mapStgBindeesAtom fn a@(StgVarArg id) = StgVarArg (fn id) +mapStgBindeesArg fn a@(StgLitArg _) = a +mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id) \end{code} diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 156f2ae..1020b67 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -15,30 +15,37 @@ module SaAbsInt ( isBot ) where -IMPORT_Trace -- ToDo: rm -import Pretty ---import FiniteMap -import Outputable - -import PrelInfo ( PrimOp(..), - intTyCon, integerTyCon, doubleTyCon, - floatTyCon, wordTyCon, addrTyCon, - PrimRep +import Ubiq{-uitous-} + +import CoreSyn +import CoreUnfold ( UnfoldingDetails(..), FormSummary ) +import CoreUtils ( unTagBinders ) +import Id ( idType, getIdStrictness, getIdUnfolding, + dataConSig ) -import Type ( isPrimType, maybeAppDataTyCon, - maybeSingleConstructorTyCon, - returnsRealWorld, - isEnumerationTyCon, TyVarTemplate, TyCon +import IdInfo ( StrictnessInfo(..), Demand(..), + wwPrim, wwStrict, wwEnum, wwUnpack ) -import CoreUtils ( unTagBinders ) -import Id ( getIdStrictness, idType, getIdUnfolding, - getDataConSig, getInstantiatedDataConSig, - DataCon(..), isBottomingId +import MagicUFs ( MagicUnfoldingFun ) +import Maybes ( maybeToBool ) +import Outputable ( Outputable(..){-instance * []-} ) +import PprStyle ( PprStyle(..) ) +import PrelInfo ( intTyCon, integerTyCon, doubleTyCon, + floatTyCon, wordTyCon, addrTyCon ) -import IdInfo -- various bits -import Maybes ( maybeToBool, Maybe(..) ) +import Pretty ( ppStr ) +import PrimOp ( PrimOp(..) ) import SaLib -import Util +import TyCon ( maybeTyConSingleCon, isEnumerationTyCon, + TyCon{-instance Eq-} + ) +import Type ( maybeAppDataTyCon, isPrimType ) +import Util ( isIn, isn'tIn, nOfThem, zipWithEqual, + pprTrace, panic, pprPanic, assertPanic + ) + +getInstantiatedDataConSig = panic "SaAbsInt.getInstantiatedDataConSig (ToDo)" +returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)" \end{code} %************************************************************************ @@ -390,7 +397,7 @@ absId anal var env (Nothing, NoStrictnessInfo, LitForm _) -> AbsTop -- Literals all terminate, and have no poison - (Nothing, NoStrictnessInfo, ConForm _ _ _) -> + (Nothing, NoStrictnessInfo, ConForm _ _) -> AbsTop -- An imported constructor won't have -- bottom components, nor poison! @@ -474,12 +481,13 @@ Things are a little different for absence analysis, because we want to make sure that any poison (?????) \begin{code} -absEval StrAnal (Prim SeqOp [t] [e]) env - = if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop +absEval StrAnal (Prim SeqOp [TyArg _, e]) env + = ASSERT(isValArg e) + 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 (Prim op ts es) env = AbsTop +absEval StrAnal (Prim op 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. @@ -490,15 +498,15 @@ absEval StrAnal (Prim op ts es) env = AbsTop -- uses boxed args and we don't know whether or not it's -- strict, so we assume laziness. (JSM) -absEval AbsAnal (Prim op ts as) env - = if any anyBot [absEvalAtom AbsAnal a env | a <- as] +absEval AbsAnal (Prim op as) env + = if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a] then AbsBot else AbsTop -- For absence analysis, we want to see if the poison shows up... -absEval anal (Con con ts as) env +absEval anal (Con con as) env | has_single_con - = AbsProd [absEvalAtom anal a env | a <- as] + = AbsProd [absEvalAtom anal a env | a <- as, isValArg a] | otherwise -- Not single-constructor = case anal of @@ -507,22 +515,22 @@ absEval anal (Con con ts as) env 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] + if any anyBot [absEvalAtom AbsAnal a env | a <- as, isValArg a] then AbsBot else AbsTop where - (_,_,_, tycon) = getDataConSig con - has_single_con = maybeToBool (maybeSingleConstructorTyCon tycon) + (_,_,_, tycon) = dataConSig con + has_single_con = maybeToBool (maybeTyConSingleCon tycon) \end{code} \begin{code} -absEval anal (Lam binder body) env +absEval anal (Lam (ValBinder binder) body) env = AbsFun [binder] body env -absEval anal (CoTyLam ty expr) env +absEval anal (Lam other_binder 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 (App f a) env | isValArg a + = absApply anal (absEval anal f env) (absEvalAtom anal a env) +absEval anal (App expr _) env = absEval anal expr env \end{code} diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index c4b7797..ef42acd 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[SaLib]{Basic datatypes, functions for the strictness analyser} @@ -16,13 +16,19 @@ module SaLib ( nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList, lookupAbsValEnv, absValFromStrictness - - -- and to make the interface self-sufficient... ) where -import IdInfo -import Outputable -import Pretty +import Ubiq{-uitous-} + +import CoreSyn ( CoreExpr(..) ) +import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, + lookupIdEnv, IdEnv(..), + GenId{-instance Outputable-} + ) +import IdInfo ( StrictnessInfo(..), Demand{-instance Outputable-} ) +import Outputable ( Outputable(..){-instance * []-} ) +import PprType ( GenType{-instance Outputable-} ) +import Pretty ( ppStr, ppCat ) \end{code} %************************************************************************ diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 6605d26..dc9926d 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -11,16 +11,31 @@ Semantique analyser) was written by Andy Gill. module StrictAnal ( saWwTopBinds, saTopBinds ) where -import Id ( addIdDemandInfo, isWrapperId, addIdStrictness, - idType, getIdDemandInfo +import Ubiq{-uitous-} + +import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict, + opt_D_dump_stranal, opt_D_simplifier_stats + ) +import CoreSyn +import Id ( idType, addIdStrictness, + getIdDemandInfo, addIdDemandInfo, + GenId{-instance Outputable-} + ) +import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo, + mkDemandInfo, willBeDemanded, DemandInfo ) -import IdInfo +import PprCore ( pprCoreBinding, pprBigCoreBinder ) +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) +import Pretty ( ppBesides, ppStr, ppInt, ppChar, ppAboves ) import SaAbsInt import SaLib -import UniqSupply -import Util +import TyVar ( GenTyVar{-instance Eq-} ) import WorkWrap -- "back-end" of strictness analyser -import WwLib ( WwM(..) ) +import Unique ( Unique{-instance Eq -} ) +import Util ( zipWith4Equal, pprTrace, panic{-ToDo:rm-} ) + +isWrapperId = panic "StrictAnal.isWrapperId (ToDo)" \end{code} @@ -72,13 +87,12 @@ Alas and alack. \begin{code} saWwTopBinds :: UniqSupply - -> (GlobalSwitch -> Bool) -> [CoreBinding] -> [CoreBinding] -saWwTopBinds us switch_chker binds +saWwTopBinds us binds = let - strflags = (switch_chker AllStrict, switch_chker NumbersStrict) + strflags = (opt_AllStrict, opt_NumbersStrict) -- mark each binder with its strictness #ifndef OMIT_STRANAL_STATS @@ -90,13 +104,13 @@ saWwTopBinds us switch_chker binds #endif in -- possibly show what we decided about strictness... - (if switch_chker D_dump_stranal + (if opt_D_dump_stranal then pprTrace "Strictness:\n" (ppAboves ( - map (pprCoreBinding PprDebug pprBigCoreBinder pprBigCoreBinder ppr) binds_w_strictness)) + map (pprCoreBinding PprDebug) binds_w_strictness)) else id ) -- possibly show how many things we marked as demanded... - ((if switch_chker D_simplifier_stats + ((if opt_D_simplifier_stats #ifndef OMIT_STRANAL_STATS then pp_stats sa_stats #else @@ -107,7 +121,7 @@ saWwTopBinds us switch_chker binds -- create worker/wrappers, and mark binders with their -- "strictness info" [which encodes their -- worker/wrapper-ness] - (workersAndWrappers binds_w_strictness us switch_chker)) + (workersAndWrappers binds_w_strictness us)) #ifndef OMIT_STRANAL_STATS where pp_stats (SaStats tlam dlam tc dc tlet dlet) @@ -232,31 +246,27 @@ environment. \begin{code} saExpr :: StrictEnv -> AbsenceEnv -> CoreExpr -> SaM CoreExpr -saExpr _ _ e@(Var _) = returnSa e -saExpr _ _ e@(Lit _) = returnSa e -saExpr _ _ e@(Con _ _ _) = returnSa e -saExpr _ _ e@(Prim _ _ _) = 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 (Lam arg body) +saExpr str_env abs_env (Lam (ValBinder arg) body) = saExpr str_env abs_env body `thenSa` \ new_body -> let new_arg = addDemandInfoToId str_env abs_env body arg in tickLambda new_arg `thenSa_` -- stats - returnSa (Lam new_arg new_body) + returnSa (Lam (ValBinder new_arg) new_body) -saExpr str_env abs_env (CoTyLam ty expr) +saExpr str_env abs_env (Lam other_binder expr) = saExpr str_env abs_env expr `thenSa` \ new_expr -> - returnSa (CoTyLam ty new_expr) + returnSa (Lam other_binder new_expr) saExpr str_env abs_env (App fun arg) = saExpr str_env abs_env fun `thenSa` \ new_fun -> 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 (SCC cc expr) = saExpr str_env abs_env expr `thenSa` \ new_expr -> returnSa (SCC cc new_expr) @@ -447,7 +457,7 @@ returnSa :: a -> SaM a {-# INLINE thenSa_ #-} {-# INLINE returnSa #-} -tickLambda :: [Id] -> SaM () +tickLambda :: Id -> SaM () tickCases :: [Id] -> SaM () tickLet :: Id -> SaM () @@ -465,7 +475,7 @@ thenSa_ expr cont stats returnSa x stats = (x, stats) tickLambda var (SaStats tlam dlam tc dc tlet dlet) - = case (tick_demanded (0,0) var) of { (IBOX(tot), IBOX(demanded)) -> + = case (tick_demanded var (0,0)) 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) diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index a82579d..4a7b076 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} @@ -8,20 +8,24 @@ module WorkWrap ( workersAndWrappers ) where -IMPORT_Trace -import Outputable -import Pretty +import Ubiq{-uitous-} -import Id ( idType, addIdStrictness, getIdStrictness, - getIdUnfolding, mkWorkerId, - replaceIdInfo, getIdInfo, idWantsToBeINLINEd +import CoreSyn +import CoreUnfold ( UnfoldingGuidance(..) ) +import CoreUtils ( coreExprType ) +import Id ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId, + getIdInfo + ) +import IdInfo ( noIdInfo, addInfo_UF, indicatesWorker, + mkStrictnessInfo, StrictnessInfo(..) ) -import IdInfo -- bits and pieces -import Maybes ( maybeToBool, Maybe(..) ) import SaLib -import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) -import Util +import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) ) import WwLib +import Util ( panic{-ToDo:rm-} ) + +replaceIdInfo = panic "WorkWrap.replaceIdInfo (ToDo)" +iWantToBeINLINEd = panic "WorkWrap.iWantToBeINLINEd (ToDo)" \end{code} We take Core bindings whose binders have their strictness attached (by @@ -37,14 +41,14 @@ info for exported values). \end{enumerate} \begin{code} -workersAndWrappers :: [CoreBinding] -> WwM [CoreBinding] +workersAndWrappers :: [CoreBinding] -> UniqSM [CoreBinding] workersAndWrappers top_binds - = mapWw (wwBind True{-top-level-}) top_binds `thenWw` \ top_binds2 -> + = mapUs (wwBind True{-top-level-}) top_binds `thenUs` \ top_binds2 -> let top_binds3 = map make_top_binding top_binds2 in - returnWw (concat top_binds3) + returnUs (concat top_binds3) where make_top_binding :: WwBinding -> [CoreBinding] @@ -63,24 +67,24 @@ turn. Non-recursive case first, then recursive... \begin{code} wwBind :: Bool -- True <=> top-level binding -> CoreBinding - -> WwM WwBinding -- returns a WwBinding intermediate form; + -> UniqSM WwBinding -- returns a WwBinding intermediate form; -- the caller will convert to Expr/Binding, -- as appropriate. wwBind top_level (NonRec binder rhs) - = wwExpr rhs `thenWw` \ new_rhs -> - tryWW binder new_rhs `thenWw` \ new_pairs -> - returnWw (WwLet [NonRec b e | (b,e) <- new_pairs]) + = wwExpr rhs `thenUs` \ new_rhs -> + tryWW binder new_rhs `thenUs` \ new_pairs -> + returnUs (WwLet [NonRec b e | (b,e) <- new_pairs]) -- Generated bindings must be non-recursive -- because the original binding was. ------------------------------ wwBind top_level (Rec pairs) - = mapWw do_one pairs `thenWw` \ new_pairs -> - returnWw (WwLet [Rec (concat new_pairs)]) + = mapUs do_one pairs `thenUs` \ new_pairs -> + returnUs (WwLet [Rec (concat new_pairs)]) where - do_one (binder, rhs) = wwExpr rhs `thenWw` \ new_rhs -> + do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs -> tryWW binder new_rhs \end{code} @@ -91,70 +95,62 @@ matching by looking for strict arguments of the correct type. ???????????????? ToDo \begin{code} -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 binders expr) - = wwExpr expr `thenWw` \ new_expr -> - returnWw (Lam binders new_expr) +wwExpr :: CoreExpr -> UniqSM CoreExpr -wwExpr (CoTyLam ty expr) - = wwExpr expr `thenWw` \ new_expr -> - returnWw (CoTyLam ty new_expr) +wwExpr e@(Var _) = returnUs e +wwExpr e@(Lit _) = returnUs e +wwExpr e@(Con _ _) = returnUs e +wwExpr e@(Prim _ _) = returnUs e -wwExpr (App e1 e2) - = wwExpr e1 `thenWw` \ new_e1 -> - returnWw (App new_e1 e2) +wwExpr (Lam binder expr) + = wwExpr expr `thenUs` \ new_expr -> + returnUs (Lam binder new_expr) -wwExpr (CoTyApp expr ty) - = wwExpr expr `thenWw` \ new_expr -> - returnWw (CoTyApp new_expr ty) +wwExpr (App f a) + = wwExpr f `thenUs` \ new_f -> + returnUs (App new_f a) wwExpr (SCC cc expr) - = wwExpr expr `thenWw` \ new_expr -> - returnWw (SCC cc new_expr) + = wwExpr expr `thenUs` \ new_expr -> + returnUs (SCC cc new_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) + = wwBind False{-not top-level-} bind `thenUs` \ intermediate_bind -> + wwExpr expr `thenUs` \ new_expr -> + returnUs (mash_ww_bind intermediate_bind new_expr) where mash_ww_bind (WwLet binds) body = mkCoLetsNoUnboxed binds body mash_ww_bind (WwCase case_fn) body = case_fn body wwExpr (Case expr alts) - = wwExpr expr `thenWw` \ new_expr -> - ww_alts alts `thenWw` \ new_alts -> - returnWw (Case new_expr new_alts) + = wwExpr expr `thenUs` \ new_expr -> + ww_alts alts `thenUs` \ new_alts -> + returnUs (Case new_expr new_alts) where ww_alts (AlgAlts alts deflt) - = mapWw ww_alg_alt alts `thenWw` \ new_alts -> - ww_deflt deflt `thenWw` \ new_deflt -> - returnWw (AlgAlts new_alts new_deflt) + = mapUs ww_alg_alt alts `thenUs` \ new_alts -> + ww_deflt deflt `thenUs` \ new_deflt -> + returnUs (AlgAlts new_alts new_deflt) ww_alts (PrimAlts alts deflt) - = mapWw ww_prim_alt alts `thenWw` \ new_alts -> - ww_deflt deflt `thenWw` \ new_deflt -> - returnWw (PrimAlts new_alts new_deflt) + = mapUs ww_prim_alt alts `thenUs` \ new_alts -> + ww_deflt deflt `thenUs` \ new_deflt -> + returnUs (PrimAlts new_alts new_deflt) ww_alg_alt (con, binders, rhs) - = wwExpr rhs `thenWw` \ new_rhs -> - returnWw (con, binders, new_rhs) + = wwExpr rhs `thenUs` \ new_rhs -> + returnUs (con, binders, new_rhs) ww_prim_alt (lit, rhs) - = wwExpr rhs `thenWw` \ new_rhs -> - returnWw (lit, new_rhs) + = wwExpr rhs `thenUs` \ new_rhs -> + returnUs (lit, new_rhs) ww_deflt NoDefault - = returnWw NoDefault + = returnUs NoDefault ww_deflt (BindDefault binder rhs) - = wwExpr rhs `thenWw` \ new_rhs -> - returnWw (BindDefault binder new_rhs) + = wwExpr rhs `thenUs` \ new_rhs -> + returnUs (BindDefault binder new_rhs) \end{code} %************************************************************************ @@ -179,7 +175,7 @@ The only reason this is monadised is for the unique supply. tryWW :: Id -- the fn binder -> CoreExpr -- the bound rhs; its innards -- are already ww'd - -> WwM [(Id, CoreExpr)] -- either *one* or *two* pairs; + -> UniqSM [(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 @@ -209,7 +205,7 @@ tryWW fn_id rhs (uvars, tyvars, args, body) = collectBinders rhs body_ty = coreExprType body in - uniqSMtoWwM (mkWwBodies body_ty tyvars args args_info) `thenWw` \ result -> + mkWwBodies body_ty tyvars args args_info `thenUs` \ result -> case result of Nothing -> -- Very peculiar. This can only happen if we hit an @@ -223,7 +219,7 @@ tryWW fn_id rhs Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) -> -- Terrific! It worked! - getUniqueWw `thenWw` \ worker_uniq -> + getUnique `thenUs` \ worker_uniq -> let worker_ty = worker_ty_w_hole body_ty @@ -246,8 +242,8 @@ tryWW fn_id rhs -- NB! the "iWantToBeINLINEd" part adds an INLINE pragma to -- the wrapper, which is of course what we want. in - returnWw [ (worker_id, worker_rhs), -- worker comes first + returnUs [ (worker_id, worker_rhs), -- worker comes first (wrapper_id, wrapper_rhs) ] -- because wrapper mentions it where - do_nothing = returnWw [ (fn_id, rhs) ] + do_nothing = returnUs [ (fn_id, rhs) ] \end{code} diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 4fa859a..4d1fa7a 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -9,38 +9,24 @@ module WwLib ( WwBinding(..), - mkWwBodies, mAX_WORKER_ARGS, - - -- our friendly worker/wrapper monad: - WwM(..), - returnWw, thenWw, mapWw, - getUniqueWw, uniqSMtoWwM - - -- and to make the interface self-sufficient... + mkWwBodies, mAX_WORKER_ARGS ) where import Ubiq{-uitous-} +import CoreSyn +import Id ( idType, mkSysLocal ) +import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) ) 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 SaLib import SrcLoc ( mkUnknownSrcLoc ) -import Type ( mkTyVarTys, mkFunTys, isPrimType, - maybeAppDataTyCon, quantifyTy +import Type ( isPrimType, mkTyVarTys, mkFunTys, maybeAppDataTyCon ) +import UniqSupply ( returnUs, thenUs, thenMaybeUs, + getUniques, UniqSM(..) ) -import UniqSupply --} -import Util ( panic ) - -infixr 9 `thenWw` +import Util ( zipWithEqual, assertPanic, panic ) quantifyTy = panic "WwLib.quantifyTy" +getInstantiatedDataConSig = panic "WwLib.getInstantiatedDataConSig" \end{code} %************************************************************************ @@ -221,7 +207,7 @@ mkWwBodies body_ty tyvars args arg_infos else -- the rest... mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos) - `thenUsMaybe` \ (wrap_frag, work_args_info, work_frag) -> + `thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) -> let (work_args, wrkr_demands) = unzip work_args_info @@ -230,7 +216,7 @@ mkWwBodies body_ty tyvars args arg_infos wrapper_w_hole = \ worker_id -> mkLam tyvars args ( wrap_frag ( - mkCoTyApps (Var worker_id) (mkTyVarTys tyvars) + mkTyApp (Var worker_id) (mkTyVarTys tyvars) )) worker_w_hole = \ orig_body -> @@ -302,7 +288,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args mk_ww_arg_processing args infos max_extra_args -- we've already discounted for absent args, -- so we don't change max_extra_args - `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) -> + `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> -- wrapper doesn't pass this arg to worker: returnUs (Just ( @@ -317,7 +303,7 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args where mk_absent_let arg arg_ty body = if not (isPrimType arg_ty) then - Let (NonRec arg (mkCoTyApp (Var aBSENT_ERROR_ID) arg_ty)) body + Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body else -- quite horrible panic "WwLib: haven't done mk_absent_let for primitives yet" @@ -354,7 +340,7 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args -- 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) -> + `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> returnUs (Just ( -- wrapper: unpack the value @@ -383,7 +369,8 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args ) mk_pk_let arg boxing_con con_tys unpk_args body - = Let (NonRec arg (Con boxing_con con_tys [VarArg a | a <- unpk_args])) + = Let (NonRec arg (Con boxing_con + (map TyArg con_tys ++ map VarArg unpk_args))) body mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args @@ -394,7 +381,7 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args -- Finish args to the right... mk_ww_arg_processing args infos max_extra_args - `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) -> + `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) -> returnUs (Just ( -- wrapper: @@ -406,55 +393,3 @@ mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args )) --) \end{code} - -%************************************************************************ -%* * -\subsection[monad-WwLib]{Simple monad for worker/wrapper} -%* * -%************************************************************************ - -In this monad, we thread a @UniqueSupply@, and we carry a -@GlobalSwitch@-lookup function downwards. - -\begin{code} -type WwM result - = UniqSupply - -> (GlobalSwitch -> Bool) - -> result - -{-# INLINE thenWw #-} -{-# INLINE returnWw #-} - -returnWw :: a -> WwM a -thenWw :: WwM a -> (a -> WwM b) -> WwM b -mapWw :: (a -> WwM b) -> [a] -> WwM [b] - -returnWw expr ns sw = expr - -thenWw m k us sw_chk - = case splitUniqSupply us of { (s1, s2) -> - case (m s1 sw_chk) of { m_res -> - k m_res s2 sw_chk }} - -mapWw f [] = returnWw [] -mapWw f (x:xs) - = f x `thenWw` \ x' -> - mapWw f xs `thenWw` \ xs' -> - returnWw (x':xs') -\end{code} - -\begin{code} -getUniqueWw :: WwM Unique -uniqSMtoWwM :: UniqSM a -> WwM a - -getUniqueWw us sw_chk = getUnique us - -uniqSMtoWwM u_obj us sw_chk = u_obj us - -thenUsMaybe :: UniqSM (Maybe a) -> (a -> UniqSM (Maybe b)) -> UniqSM (Maybe b) -thenUsMaybe m k - = m `thenUs` \ result -> - case result of - Nothing -> returnUs Nothing - Just x -> k x -\end{code} diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs index 27e4a00..438e59a 100644 --- a/ghc/compiler/typecheck/GenSpecEtc.lhs +++ b/ghc/compiler/typecheck/GenSpecEtc.lhs @@ -9,8 +9,7 @@ module GenSpecEtc ( TcSigInfo(..), genBinds, - checkSigTyVars, checkSigTyVarsGivenGlobals, - specTy + checkSigTyVars, checkSigTyVarsGivenGlobals ) where import Ubiq @@ -26,7 +25,7 @@ import TcType ( TcType(..), TcThetaType(..), TcTauType(..), import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..), Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake ) -import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..) ) +import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..), tcIdType ) import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag ) import Class ( GenClass ) @@ -155,7 +154,7 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn -- BUILD THE NEW LOCALS let tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order - dict_tys = [idType d | TcId d <- dicts_bound] -- Slightly ugh-ish + dict_tys = map tcIdType dicts_bound 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) @@ -282,12 +281,12 @@ The error message here is somewhat unsatisfactory, but it'll do for now (ToDo). \begin{code} -checkSigMatch :: TcSigInfo s -> TcM s [TcTyVar s] +checkSigMatch :: TcSigInfo s -> TcM s () checkSigMatch (TySigInfo id sig_tyvars _ tau_ty src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (sigCtxt id) $ - checkSigTyVars sig_tyvars tau_ty (idType id) + checkSigTyVars sig_tyvars tau_ty \end{code} @@ -337,6 +336,8 @@ are eg matching signature [(a,b)] against inferred type [(p,p)] [then a and b will be unified together] +BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS + (c) not mentioned in the environment eg the signature for f in this: @@ -351,71 +352,30 @@ Before doing this, the substitution is applied to the signature type variable. \begin{code} 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 + -> TcM s () -checkSigTyVars sig_tyvars sig_tau inferred_tau +checkSigTyVars sig_tyvars sig_tau = tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars -> - checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_tau inferred_tau + checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_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) - checkTcM (hasNoDups sig_tyvars') match_err `thenTc_` + -> TcM s () - -- Check point (c) +checkSigTyVarsGivenGlobals globals sig_tyvars sig_tau + = -- Check point (c) -- We want to report errors in terms of the original signature tyvars, -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond -- 1-1 with sig_tyvars, so we can just map back. - let - mono_tyvars = [ sig_tyvar - | (sig_tyvar,sig_tyvar') <- zipEqual sig_tyvars sig_tyvars', - sig_tyvar' `elementOfTyVarSet` globals - ] - in checkTc (null mono_tyvars) - (notAsPolyAsSigErr sig_tau mono_tyvars) `thenTc_` - - returnTc sig_tyvars' + (notAsPolyAsSigErr sig_tau mono_tyvars) where - match_err = zonkTcType inferred_tau `thenNF_Tc` \ inferred_tau' -> - failTc (badMatchErr sig_tau inferred_tau') + mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars \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 diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 7ad462e..e4a9584 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -10,7 +10,7 @@ module Inst ( Inst(..), -- Visible only to TcSimplify InstOrigin(..), OverloadedLit(..), - LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, + LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, InstanceMapper(..), @@ -41,7 +41,7 @@ import TcEnv ( tcLookupGlobalValueByKey ) import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..), tcInstType, tcInstTcType, zonkTcType ) -import Bag ( Bag, emptyBag, unitBag, unionBags, listToBag, consBag ) +import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv ) import Id ( GenId, idType, mkInstId ) import MatchEnv ( lookupMEnv, insertMEnv ) @@ -78,6 +78,7 @@ emptyLIE = emptyBag unitLIE inst = unitBag inst plusLIE lie1 lie2 = lie1 `unionBags` lie2 consLIE inst lie = inst `consBag` lie +plusLIEs lies = unionManyBags lies zonkLIE :: LIE s -> NF_TcM s (LIE s) zonkLIE lie = mapBagNF_Tc zonkInst lie diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 9ecbe7f..912a415 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -182,7 +182,7 @@ tcBindAndSigs binder_names bind sigs prag_info_fn -- 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 -> + newTcTyVar 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) @@ -271,13 +271,15 @@ 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 -> + tcInstType [] sigma_ty `thenNF_Tc` \ sigma_ty' -> let - (tyvars, theta, tau_ty) = splitSigmaTy tc_sigma_ty + (tyvars', theta', tau') = splitSigmaTy sigma_ty' in + tcLookupLocalValueOK "tcSig1" v `thenNF_Tc` \ val -> - unifyTauTy (idType val) tau_ty `thenTc_` - returnTc (TySigInfo val tyvars theta tau_ty src_loc) + unifyTauTy (idType val) tau' `thenTc_` + + returnTc (TySigInfo val tyvars' theta' tau' src_loc) ) `thenTc` \ sig_info1 -> tcTySigs other_sigs `thenTc` \ sig_infos -> @@ -386,7 +388,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- Get and instantiate its alleged specialised type tcPolyType poly_ty `thenTc` \ sig_sigma -> - tcInstType [] (idType sig_sigma) `thenNF_Tc` \ sig_ty -> + tcInstType [] sig_sigma `thenNF_Tc` \ sig_ty -> let (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty origin = ValSpecOrigin name @@ -407,8 +409,8 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- Check that the specialised type is indeed an instance of -- the type of the main function. - unifyTauTy sig_tau main_tau `thenTc_` - checkSigTyVars sig_tyvars sig_tau main_tau `thenTc_` + unifyTauTy sig_tau main_tau `thenTc_` + checkSigTyVars sig_tyvars sig_tau `thenTc_` -- Check that the type variables of the polymorphic function are -- either left polymorphic, or instantiate to ground type. @@ -447,8 +449,8 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- 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_` + unifyTauTy sig_tau spec_tau `thenTc_` + checkSigTyVars sig_tyvars sig_tau `thenTc_` -- Make a local SpecId to bind to applied spec_id newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id -> diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 7bb5dc7..e5cb1f3 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -24,13 +24,12 @@ 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 TcKind ( unifyKind ) import TcMonoType ( tcMonoType, tcContext ) -import TcType ( TcTyVar(..), tcInstType, tcInstTyVar ) +import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars ) import TcKind ( TcKind ) import Bag ( foldBag ) @@ -246,6 +245,11 @@ tcClassDecl2 :: RenamedClassDecl -- The class declaration tcClassDecl2 (ClassDecl context class_name tyvar_name class_sigs default_binds pragmas src_loc) + + | not (isLocallyDefined class_name) + = returnNF_Tc (emptyLIE, EmptyBinds) + + | otherwise -- It is locally defined = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $ tcAddSrcLoc src_loc $ @@ -255,14 +259,14 @@ tcClassDecl2 (ClassDecl context class_name (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids) = getClassBigSig clas in - tcInstTyVar tyvar `thenNF_Tc` \ clas_tyvar -> + tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) -> -- Generate bindings for the selector functions - buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids - `thenNF_Tc` \ sel_binds -> + buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids + `thenNF_Tc` \ sel_binds -> -- Ditto for the methods buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds - `thenTc` \ (const_insts, meth_binds) -> + `thenTc` \ (const_insts, meth_binds) -> returnTc (const_insts, sel_binds `ThenBinds` meth_binds) \end{code} @@ -275,29 +279,33 @@ tcClassDecl2 (ClassDecl context class_name \begin{code} buildSelectors :: Class -- The class object - -> TcTyVar s -- Class type variable + -> TyVar -- Class type variable + -> TcTyVar s -- Instantiated class type variable (TyVarTy) -> [Class] -> [Id] -- Superclasses and selectors -> [ClassOp] -> [Id] -- Class ops and selectors -> NF_TcM s (TcHsBinds s) -buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids +buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids = -- Make new Ids for the components of the dictionary - mapNF_Tc (tcInstType [] . getClassOpLocalType) ops `thenNF_Tc` \ op_tys -> - + let + clas_tyvar_ty = mkTyVarTy clas_tc_tyvar + mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . getClassOpLocalType + in + mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys -> newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids -> newDicts ClassDeclOrigin - [ (super_clas, mkTyVarTy clas_tyvar) + [ (super_clas, clas_tyvar_ty) | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) -> newDicts ClassDeclOrigin - [ (clas, mkTyVarTy clas_tyvar) ] `thenNF_Tc` \ (_,[clas_dict]) -> + [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) -> -- Make suitable bindings for the selectors let mk_sel sel_id method_or_dict - = mkSelBind sel_id clas_tyvar clas_dict dict_ids method_ids method_or_dict + = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict in listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds -> listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds -> @@ -444,7 +452,7 @@ dfun.Foo.List = /\ a -> \ dfoo_a -> let rec op1 = defm.Foo.op1 [a] dfoo_list - op2 = /\b -> defm.Foo.op2 [a] b dfoo_list + op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord dfoo_list = (op1, op2) in dfoo_list @@ -483,7 +491,11 @@ makeClassDeclDefaultMethodRhs -> NF_TcM s (TcExpr s) makeClassDeclDefaultMethodRhs clas method_ids tag - = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) -> + = tcInstType [] (idType method_id) `thenNF_Tc` \ method_ty -> + let + (tyvars, theta, tau) = splitSigmaTy method_ty + in + newDicts ClassDeclOrigin theta `thenNF_Tc` \ (lie, dict_ids) -> returnNF_Tc (mkHsTyLam tyvars ( mkHsDictLam dict_ids ( diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 8912626..06e15fc 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -35,8 +35,8 @@ import RnBinds4 ( rnMethodBinds, rnTopBinds ) import Bag ( Bag, isEmptyBag, unionBags, listToBag ) import Class ( GenClass, getClassKey ) -import ErrUtils ( pprBagOfErrors, addErrLoc, TcError(..) ) -import Id ( getDataConSig, getDataConArity ) +import ErrUtils ( pprBagOfErrors, addErrLoc ) +import Id ( dataConSig, dataConArity ) import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) import Name ( Name(..) ) import NameTypes ( mkPreludeCoreName, Provenance(..) ) @@ -46,7 +46,7 @@ import PprStyle import Pretty import ProtoName ( eqProtoName, ProtoName(..), Name ) import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc ) -import TyCon ( getTyConTyVars, getTyConDataCons, getTyConDerivings, +import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, maybeTyConSingleCon, isEnumerationTyCon, TyCon ) import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon, mkSigmaTy, mkDictTy, isPrimType, instantiateTy, @@ -266,7 +266,7 @@ makeDerivEqns need_deriving tycons_to_consider = foldr ( \ tycon acc -> - case (getTyConDerivings tycon) of + case (tyConDerivings tycon) of [] -> acc cs -> [ (clas,tycon) | clas <- cs ] ++ acc ) @@ -303,9 +303,9 @@ makeDerivEqns mk_eqn (clas, tycon) = (clas, tycon, tyvars, constraints) where - tyvars = getTyConTyVars tycon -- ToDo: Do we need new tyvars ??? + tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ??? tyvar_tys = mkTyVarTys tyvars - data_cons = getTyConDataCons tycon + data_cons = tyConDataCons tycon constraints = concat (map mk_constraints data_cons) mk_constraints data_con @@ -314,7 +314,7 @@ makeDerivEqns not (isPrimType arg_ty) -- No constraints for primitive types ] where - (con_tyvars, _, arg_tys, _) = getDataConSig data_con + (con_tyvars, _, arg_tys, _) = dataConSig data_con inst_env = con_tyvars `zipEqual` tyvar_tys -- same number of tyvars in data constr and type constr! \end{code} @@ -638,7 +638,7 @@ gen_taggery_Names eqns where do_con2tag acc_Names tycon = if (we_are_deriving eqClassKey tycon - && any ( (== 0).getDataConArity ) (getTyConDataCons tycon)) + && any ( (== 0).dataConArity ) (tyConDataCons tycon)) || (we_are_deriving ordClassKey tycon && not (maybeToBool (maybeTyConSingleCon tycon))) || (we_are_deriving enumClassKey tycon) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 42a6c9b..8ca0034 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -13,7 +13,7 @@ module TcEnv( tcExtendGlobalValEnv, tcExtendLocalValEnv, tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, - tcLookupGlobalValue, tcLookupGlobalValueByKey, + tcLookupGlobalValue, tcLookupGlobalValueByKey, tcGlobalOcc, newMonoIds, newLocalIds, newLocalId, tcGetGlobalTyVars @@ -25,11 +25,13 @@ import TcMLoop -- for paranoia checking import Id ( Id(..), GenId, idType, mkUserLocal ) import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) ) -import TcKind ( TcKind, newKindVars, tcKindToKind, kindToTcKind ) -import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), newTyVarTys, zonkTcTyVars ) +import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind ) +import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), + newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars + ) import TyVar ( mkTyVar, getTyVarKind, unionTyVarSets, emptyTyVarSet ) import Type ( tyVarsOfTypes ) -import TyCon ( TyCon, Arity(..), getTyConKind, getSynTyConArity ) +import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity ) import Class ( Class(..), GenClass, getClassSig ) import TcMonad @@ -37,9 +39,10 @@ import TcMonad import Name ( Name(..), getNameShortName ) import PprStyle import Pretty +import Type ( splitForAllTy ) import Unique ( Unique ) import UniqFM -import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic ) +import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic ) \end{code} Data type declarations @@ -89,7 +92,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside (thing_inside rec_tyvars) `thenTc` \ result -> -- Get the tyvar's Kinds from their TcKinds - mapNF_Tc tcKindToKind kinds `thenNF_Tc` \ kinds' -> + mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' -> -- Construct the real TyVars let @@ -123,7 +126,10 @@ tcExtendTyConEnv names_w_arities tycons scope (kinds `zipLazy` tycons) ] in - tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope + tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope `thenTc` \ result -> + mapNF_Tc tcDefaultKind kinds `thenNF_Tc_` + returnTc result + tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r tcExtendClassEnv names classes scope @@ -132,7 +138,9 @@ tcExtendClassEnv names classes scope let ce' = addListToUFM ce (names `zip` (kinds `zipLazy` classes)) in - tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope + tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope `thenTc` \ result -> + mapNF_Tc tcDefaultKind kinds `thenNF_Tc_` + returnTc result \end{code} @@ -145,7 +153,7 @@ tcLookupTyVar name tcLookupTyCon (WiredInTyCon tc) -- wired in tycons - = returnNF_Tc (kindToTcKind (getTyConKind tc), getSynTyConArity tc, tc) + = returnNF_Tc (kindToTcKind (tyConKind tc), synTyConArity tc, tc) tcLookupTyCon name = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> @@ -154,7 +162,9 @@ tcLookupTyCon name tcLookupTyConByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce (panic "tcLookupTyCon") uniq + (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce + (pprPanic "tcLookupTyCon:" (ppr PprDebug uniq)) + uniq in returnNF_Tc tycon @@ -165,7 +175,9 @@ tcLookupClass name tcLookupClassByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - (kind, clas) = lookupWithDefaultUFM_Directly ce (panic "tcLookupClas") uniq + (kind, clas) = lookupWithDefaultUFM_Directly ce + (pprPanic "tcLookupClas:" (ppr PprDebug uniq)) + uniq in returnNF_Tc clas \end{code} @@ -236,11 +248,27 @@ tcLookupGlobalValue name returnNF_Tc (lookupWithDefaultUFM gve def name) where #ifdef DEBUG - def = panic ("tcLookupGlobalValue:" ++ ppShow 1000 (ppr PprDebug name)) + def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name) #else def = panic "tcLookupGlobalValue" #endif +-- A useful function that takes an occurrence of a global thing +-- and instantiates its type with fresh type variables +tcGlobalOcc :: Name + -> NF_TcM s (Id, -- The Id + [TcType s], -- Instance types + TcType s) -- Rest of its type + +tcGlobalOcc name + = tcLookupGlobalValue name `thenNF_Tc` \ id -> + let + (tyvars, rho) = splitForAllTy (idType id) + in + tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> + tcInstType tenv rho `thenNF_Tc` \ rho' -> + returnNF_Tc (id, arg_tys, rho') + tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id tcLookupGlobalValueByKey uniq @@ -248,7 +276,7 @@ tcLookupGlobalValueByKey uniq returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq) where #ifdef DEBUG - def = panic ("tcLookupGlobalValueByKey:" ++ ppShow 1000 (ppr PprDebug uniq)) + def = pprPanic "tcLookupGlobalValueByKey:" (ppr PprDebug uniq) #else def = panic "tcLookupGlobalValueByKey" #endif diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 9f911d4..660c970 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -15,45 +15,56 @@ import HsSyn ( HsExpr(..), Qual(..), Stmt(..), ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, Match, Fake, InPat, OutPat, PolyType, irrefutablePat, collectPatBinders ) -import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..), RenamedStmt(..) ) -import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..), TcIdOcc(..) ) +import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..), + RenamedStmt(..), RenamedRecordBinds(..) + ) +import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..), + TcIdOcc(..), TcRecordBinds(..), + mkHsTyApp + ) import TcMonad import Inst ( Inst, InstOrigin(..), OverloadedLit(..), - LIE(..), emptyLIE, plusLIE, newOverloadedLit, + LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newMethodWithGivenTy, newDicts ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, - tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars ) + tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars, + tcGlobalOcc + ) import TcMatches ( tcMatchesCase, tcMatch ) import TcMonoType ( tcPolyType ) import TcPat ( tcPat ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) -import TcType ( TcType(..), TcMaybe(..), tcReadTyVar, - tcInstType, tcInstTcType, - tcInstTyVar, newTyVarTy, zonkTcTyVars ) +import TcType ( TcType(..), TcMaybe(..), + tcInstType, tcInstTcType, tcInstTyVars, + newTyVarTy, zonkTcTyVars, zonkTcType ) import TcKind ( TcKind ) import Class ( Class(..), getClassSig ) -import Id ( Id(..), GenId, idType ) -import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals, specTy ) +import FieldLabel ( fieldLabelName ) +import Id ( Id(..), GenId, idType, dataConFieldLabels ) +import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) +import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals ) import PrelInfo ( intPrimTy, charPrimTy, doublePrimTy, floatPrimTy, addrPrimTy, addrTy, boolTy, charTy, stringTy, mkListTy, mkTupleTy, mkPrimIoTy ) import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, getTyVar_maybe, getFunTy_maybe, - splitForAllTy, splitRhoTy, splitSigmaTy, - isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe ) + splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy, + isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe, + maybeAppDataTyCon + ) import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet ) -import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) +import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, monadClassKey, monadZeroClassKey ) import Name ( Name ) -- Instance +import Outputable ( interpp'SP ) import PprType ( GenType, GenTyVar ) -- Instances import Maybes ( maybeToBool ) import Pretty @@ -302,24 +313,18 @@ 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 - (tv,_,_) = getClassSig monadClass - in - tcInstTyVar tv `thenNF_Tc` \ m_tyvar -> - let - m = mkTyVarTy m_tyvar - in - tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) -> + newTyVarTy monadKind `thenNF_Tc` \ m -> + tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) -> -- create dictionaries for monad and possibly monadzero (if monad then + tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass -> newDicts DoOrigin [(monadClass, m)] else returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"]) ) `thenNF_Tc` \ (m_lie, [m_id]) -> (if mzero then + tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass -> newDicts DoOrigin [(monadZeroClass, m)] else returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"]) @@ -328,6 +333,8 @@ tcExpr (HsDo stmts src_loc) returnTc (HsDoOut stmts' m_id mz_id src_loc, lie `plusLIE` m_lie `plusLIE` mz_lie, do_ty) + where + monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind \end{code} \begin{code} @@ -346,10 +353,41 @@ tcExpr (ExplicitTuple exprs) = tcExprs exprs `thenTc` \ (exprs', lie, tys) -> returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys) -tcExpr (RecordCon con rbinds) - = panic "tcExpr:RecordCon" -tcExpr (RecordUpd exp rbinds) - = panic "tcExpr:RecordUpd" +tcExpr (RecordCon (HsVar con) rbinds) + = tcGlobalOcc con `thenNF_Tc` \ (con_id, arg_tys, con_rho) -> + let + (con_theta, con_tau) = splitRhoTy con_rho + (_, record_ty) = splitFunTy con_tau + con_expr = mkHsTyApp (HsVar (RealId con_id)) arg_tys + in + -- TEMPORARY ASSERT + ASSERT( null con_theta ) + + -- Con is syntactically constrained to be a data constructor + ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) ) + + tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> + + checkTc (checkRecordFields rbinds con_id) + (badFieldsCon con rbinds) `thenTc_` + + returnTc (RecordCon con_expr rbinds', panic "tcExpr:RecordCon:con_lie???" {-con_lie???-} `plusLIE` rbinds_lie, record_ty) + +tcExpr (RecordUpd record_expr rbinds) + = tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) -> + tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> + + -- Check that the field names are plausible + zonkTcType record_ty `thenNF_Tc` \ record_ty' -> + let + maybe_tycon_stuff = maybeAppDataTyCon record_ty' + Just (tycon, args_tys, data_cons) = maybe_tycon_stuff + in + checkTc (maybeToBool maybe_tycon_stuff) + (panic "TcExpr:Records:mystery error message") `thenTc_` + checkTc (any (checkRecordFields rbinds) data_cons) + (badFieldsUpd rbinds) `thenTc_` + returnTc (RecordUpd record_expr' rbinds', record_lie `plusLIE` rbinds_lie, record_ty) tcExpr (ArithSeqIn seq@(From expr)) = tcExpr expr `thenTc` \ (expr', lie1, ty) -> @@ -425,13 +463,17 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) -- Check the tau-type part tcSetErrCtxt (exprSigCtxt in_expr) $ - specTy SignatureOrigin sigma_sig `thenNF_Tc` \ (sig_tyvars, sig_dicts, sig_tau, _) -> - unifyTauTy tau_ty sig_tau `thenTc_` + tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' -> + let + (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig' + in + unifyTauTy tau_ty sig_tau' `thenTc_` -- Check the type variables of the signature - checkSigTyVars sig_tyvars sig_tau tau_ty `thenTc` \ sig_tyvars' -> + checkSigTyVars sig_tyvars' sig_tau' `thenTc_` -- Check overloading constraints + newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) -> tcSimplifyAndCheck (mkTyVarSet sig_tyvars') sig_dicts lie `thenTc_` @@ -485,46 +527,23 @@ tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error m tcApp_help orig_fun arg_no fun_ty [] = returnTc ([], emptyLIE, fun_ty) -tcApp_help orig_fun arg_no fun_ty (arg:args) - | maybeToBool maybe_arrow_ty - = -- The function's type is A->B +tcApp_help orig_fun arg_no fun_ty all_args@(arg:args) + = -- Expect the function to have type A->B + tcAddErrCtxt (tooManyArgsCtxt orig_fun) ( + unifyFunTy fun_ty + ) `thenTc` \ (expected_arg_ty, result_ty) -> + + -- Type check the argument tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) ( - tcArg expected_arg_ty arg - ) `thenTc` \ (arg', lie_arg) -> + tcArg expected_arg_ty arg + ) `thenTc` \ (arg', lie_arg) -> + -- Do the other args 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) - - | 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) - - 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) -> - - -- 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 + -- Done + returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty) - maybe_tyvar_ty = getTyVar_maybe fun_ty - Just fun_tyvar = maybe_tyvar_ty \end{code} \begin{code} @@ -550,7 +569,7 @@ tcArg expected_arg_ty arg let (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty in - ASSERT( null expected_theta ) + ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things -- Type-check the arg and unify with expected type tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) -> @@ -571,19 +590,19 @@ tcArg expected_arg_ty arg 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' -> + expected_tyvars expected_tau `thenTc_` -- Check that there's no overloading involved - -- Even if there isn't, there may be some Insts which mention the arg_tyvars, + -- Even if there isn't, there may be some Insts which mention the expected_tyvars, -- but which, on simplification, don't actually need a dictionary involving -- the tyvar. So we have to do a proper simplification right here. - tcSimplifyRank2 (mkTyVarSet arg_tyvars') + tcSimplifyRank2 (mkTyVarSet expected_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) + returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts) ) where @@ -605,29 +624,30 @@ tcArg expected_arg_ty arg 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 = mkTyVarTys tyvars - in + tcLookupLocalValue name `thenNF_Tc` \ maybe_local -> + + (case maybe_local of + Just tc_id -> let + (tyvars, rho) = splitForAllTy (idType tc_id) + in + tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys', tenv) -> + tcInstTcType tenv rho `thenNF_Tc` \ rho' -> + returnNF_Tc (TcId tc_id, arg_tys', rho') + + Nothing -> tcGlobalOcc name `thenNF_Tc` \ (id, arg_tys, rho) -> + returnNF_Tc (RealId id, arg_tys, rho) + + ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) -> + -- 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) + case splitRhoTy rho of + ([], tau) -> -- Not overloaded, so just make a type application + returnTc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau) + + (theta, tau) -> -- Overloaded, so make a Method inst + newMethodWithGivenTy (OccurrenceOf tc_id_occ) + tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) -> + returnTc (HsVar meth_id, lie, tau) \end{code} @@ -752,6 +772,65 @@ tcDoStmts monad m (LetStmt binds : stmts) \end{code} +Game plan for record bindings +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For each binding + field = value +1. look up "field", to find its selector Id, which must have type + forall a1..an. T a1 .. an -> tau + where tau is the type of the field. + +2. Instantiate this type + +3. Unify the (T a1 .. an) part with the "expected result type", which + is passed in. This checks that all the field labels come from the + same type. + +4. Type check the value using tcArg, passing tau as the expected + argument type. + +This extends OK when the field types are universally quantified. + +Actually, to save excessive creation of fresh type variables, +we + +\begin{code} +tcRecordBinds + :: TcType s -- Expected type of whole record + -> RenamedRecordBinds + -> TcM s (TcRecordBinds s, LIE s) + +tcRecordBinds expected_record_ty rbinds + = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) -> + returnTc (rbinds', plusLIEs lies) + where + do_bind (field_label, rhs, pun_flag) + = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) -> + + -- Record selectors all have type + -- forall a1..an. T a1 .. an -> tau + ASSERT( maybeToBool (getFunTy_maybe tau) ) + let + -- Selector must have type RecordType -> FieldType + Just (record_ty, field_ty) = getFunTy_maybe tau + in + unifyTauTy expected_record_ty record_ty `thenTc_` + tcArg field_ty rhs `thenTc` \ (rhs', lie) -> + returnTc ((RealId sel_id, rhs', pun_flag), lie) + +checkRecordFields :: RenamedRecordBinds -> Id -> Bool -- True iff all the fields in + -- RecordBinds are field of the + -- specified constructor +checkRecordFields rbinds data_con + = all ok rbinds + where + data_con_fields = dataConFieldLabels data_con + + ok (field_name, _, _) = any (match field_name) data_con_fields + + match field_name field_label = field_name == fieldLabelName field_label +\end{code} + %************************************************************************ %* * \subsection{@tcExprs@ typechecks a {\em list} of expressions} @@ -821,7 +900,7 @@ stmtCtxt stmt sty = ppHang (ppStr "In a do statement:") 4 (ppr sty stmt) -tooManyArgs f sty +tooManyArgsCtxt f sty = ppHang (ppStr "Too many arguments in an application of the function") 4 (ppr sty f) @@ -834,5 +913,16 @@ 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} +badFieldsUpd rbinds sty + = ppHang (ppStr "In a record update construct, no constructor has all these fields:") + 4 (interpp'SP sty fields) + where + fields = [field | (field, _, _) <- rbinds] + +badFieldsCon con rbinds sty + = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con]) + 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields]) + where + fields = [field | (field, _, _) <- rbinds] +\end{code} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 6a70127..3dfcc03 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -73,8 +73,8 @@ import RnHsSyn ( RenamedFixityDecl(..) ) import RnMonad4 -- initRn4, etc. import RnUtils -import Id ( GenId, getDataConArity, getDataConTag, - getDataConSig, fIRST_TAG, +import Id ( GenId, dataConArity, dataConTag, + dataConSig, fIRST_TAG, isDataCon, DataCon(..), ConTag(..) ) import IdUtils ( primOpId ) import Maybes ( maybeToBool ) @@ -86,7 +86,7 @@ import PrelInfo import Pretty import ProtoName ( ProtoName(..) ) import SrcLoc ( mkGeneratedSrcLoc ) -import TyCon ( TyCon, getTyConDataCons, isEnumerationTyCon, maybeTyConSingleCon ) +import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon ) import Type ( eqTy, isPrimType ) import Unique import Util @@ -175,8 +175,8 @@ instance ... Eq (Foo ...) where gen_Eq_binds :: TyCon -> ProtoNameMonoBinds gen_Eq_binds tycon - = case (partition (\ con -> getDataConArity con == 0) - (getTyConDataCons tycon)) + = case (partition (\ con -> dataConArity con == 0) + (tyConDataCons tycon)) of { (nullary_cons, nonnullary_cons) -> let rest @@ -201,9 +201,9 @@ gen_Eq_binds tycon con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) data_con_PN = Prel (WiredInVal data_con) - as_needed = take (getDataConArity data_con) as_PNs - bs_needed = take (getDataConArity data_con) bs_PNs - tys_needed = case (getDataConSig data_con) of + as_needed = take (dataConArity data_con) as_PNs + bs_needed = take (dataConArity data_con) bs_PNs + tys_needed = case (dataConSig data_con) of (_,_, arg_tys, _) -> arg_tys in ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) @@ -342,7 +342,7 @@ gen_Ord_binds tycon (cmp_tags_Expr ltH_PN ah_PN bh_PN ltTag_Expr gtTag_Expr))) (nullary_cons, nonnullary_cons) - = partition (\ con -> getDataConArity con == 0) (getTyConDataCons tycon) + = partition (\ con -> dataConArity con == 0) (tyConDataCons tycon) cmp_eq = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc) @@ -355,9 +355,9 @@ gen_Ord_binds tycon con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) data_con_PN = Prel (WiredInVal data_con) - as_needed = take (getDataConArity data_con) as_PNs - bs_needed = take (getDataConArity data_con) bs_PNs - tys_needed = case (getDataConSig data_con) of + as_needed = take (dataConArity data_con) as_PNs + bs_needed = take (dataConArity data_con) bs_PNs + tys_needed = case (dataConSig data_con) of (_,_, arg_tys, _) -> arg_tys nested_compare_expr [ty] [a] [b] @@ -570,21 +570,21 @@ gen_Ix_binds tycon = case maybeTyConSingleCon tycon of -- just checking... Nothing -> panic "get_Ix_binds" Just dc -> let - (_, _, arg_tys, _) = getDataConSig dc + (_, _, arg_tys, _) = dataConSig dc in if any isPrimType arg_tys then error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str) else dc - con_arity = getDataConArity data_con + con_arity = dataConArity data_con data_con_PN = Prel (WiredInVal data_con) con_pat xs = ConPatIn data_con_PN (map VarPatIn 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 - cs_needed = take (getDataConArity data_con) cs_PNs + as_needed = take (dataConArity data_con) as_PNs + bs_needed = take (dataConArity data_con) bs_PNs + cs_needed = take (dataConArity data_con) cs_PNs -------------------------------------------------------------- single_con_range @@ -645,7 +645,7 @@ gen_Read_binds fixities tycon reads_prec = let read_con_comprehensions - = map read_con (getTyConDataCons tycon) + = map read_con (tyConDataCons tycon) in mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] ( foldl1 append_Expr read_con_comprehensions @@ -655,10 +655,10 @@ gen_Read_binds fixities tycon = let data_con_PN = Prel (WiredInVal data_con) data_con_str= snd (getOrigName data_con) - as_needed = take (getDataConArity data_con) as_PNs - bs_needed = take (getDataConArity data_con) bs_PNs + as_needed = take (dataConArity data_con) as_PNs + bs_needed = take (dataConArity data_con) bs_PNs con_expr = foldl HsApp (HsVar data_con_PN) (map HsVar as_needed) - nullary_con = getDataConArity data_con == 0 + nullary_con = dataConArity data_con == 0 con_qual = GeneratorQual @@ -696,14 +696,14 @@ gen_Show_binds fixities tycon (HsApp (HsVar _showList_PN) (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))) ----------------------------------------------------------------------- shows_prec - = mk_FunMonoBind showsPrec_PN (map pats_etc (getTyConDataCons tycon)) + = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon)) where pats_etc data_con = let data_con_PN = Prel (WiredInVal data_con) - bs_needed = take (getDataConArity data_con) bs_PNs + bs_needed = take (dataConArity data_con) bs_PNs con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) - nullary_con = getDataConArity data_con == 0 + nullary_con = dataConArity data_con == 0 show_con = let (mod, nm) = getOrigName data_con @@ -773,19 +773,19 @@ gen_tag_n_con_monobind -> ProtoNameMonoBinds gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag) - = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon)) + = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon)) where mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr) mk_stuff var = ASSERT(isDataCon var) - ([pat], HsLit (HsIntPrim (toInteger ((getDataConTag var) - fIRST_TAG)))) + ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))) where - pat = ConPatIn var_PN (nOfThem (getDataConArity var) WildPatIn) + pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn) var_PN = Prel (WiredInVal var) gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con) - = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon)) + = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon)) where mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr) @@ -793,13 +793,13 @@ gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con) = ASSERT(isDataCon var) ([lit_pat], HsVar var_PN) where - lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((getDataConTag var) - fIRST_TAG)))] + lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))] var_PN = Prel (WiredInVal var) gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag) = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag))) where - max_tag = case (getTyConDataCons tycon) of + max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) \end{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 005fec5..996658b 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -10,16 +10,21 @@ checker. module TcHsSyn ( TcIdBndr(..), TcIdOcc(..), - TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..), TcExpr(..), TcGRHSsAndBinds(..), - TcGRHS(..), TcMatch(..), TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcHsModule(..), + TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..), + TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..), + TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..), + TcHsModule(..), - TypecheckedHsBinds(..), TypecheckedBind(..), TypecheckedMonoBinds(..), - TypecheckedPat(..), TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..), - TypecheckedQual(..), TypecheckedStmt(..), TypecheckedMatch(..), - TypecheckedHsModule(..), TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..), + TypecheckedHsBinds(..), TypecheckedBind(..), + TypecheckedMonoBinds(..), TypecheckedPat(..), + TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..), + TypecheckedQual(..), TypecheckedStmt(..), + TypecheckedMatch(..), TypecheckedHsModule(..), + TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..), mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, + tcIdType, zonkBinds, zonkInst, @@ -32,7 +37,7 @@ import Ubiq{-uitous-} -- friends: import HsSyn -- oodles of it import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids - DictVar(..) + DictVar(..), idType ) -- others: @@ -76,6 +81,7 @@ 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 TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TypecheckedPat = OutPat TyVar UVar Id @@ -104,6 +110,10 @@ mkHsTyLam tyvars expr = TyLam tyvars expr mkHsDictLam [] expr = expr mkHsDictLam dicts expr = DictLam dicts expr + +tcIdType :: TcIdOcc s -> TcType s +tcIdType (TcId id) = idType id +tcIdType other = panic "tcIdType" \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 6e3db5b..43d29fb 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -25,13 +25,13 @@ import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..), RenamedInstDecl(..), RenamedFixityDecl(..), RenamedSig(..), RenamedSpecInstSig(..) ) import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), - TcMonoBinds(..), TcExpr(..), + TcMonoBinds(..), TcExpr(..), tcIdType, mkHsTyLam, mkHsTyApp, mkHsDictLam, mkHsDictApp ) import TcMonad -import GenSpecEtc ( checkSigTyVars, specTy ) +import GenSpecEtc ( checkSigTyVars ) import Inst ( Inst, InstOrigin(..), InstanceMapper(..), newDicts, newMethod, LIE(..), emptyLIE, plusLIE ) import TcBinds ( tcPragmaSigs ) @@ -44,7 +44,8 @@ import TcMatches ( tcMatchesFun ) import TcMonoType ( tcContext, tcMonoTypeKind ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas ) import TcType ( TcType(..), TcTyVar(..), - tcInstTyVar, tcInstType, tcInstTheta ) + tcInstSigTyVars, tcInstType, tcInstTheta + ) import Unify ( unifyTauTy ) @@ -64,7 +65,7 @@ import Name ( Name, getTagFromClassOpName ) import Outputable import PrelInfo ( pAT_ERROR_ID ) import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, - pprParendType ) + pprParendGenType ) import PprStyle import Pretty import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) @@ -346,10 +347,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty tcAddSrcLoc locn $ -- Get the class signature - mapNF_Tc tcInstTyVar inst_tyvars `thenNF_Tc` \ inst_tyvars' -> + tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) -> let - tenv = inst_tyvars `zip` (mkTyVarTys inst_tyvars') - (class_tyvar, super_classes, sc_sel_ids, class_ops, op_sel_ids, defm_ids) = getClassBigSig clas @@ -378,9 +377,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty mk_method_expr = if opt_OmitDefaultInstanceMethods then - makeInstanceDeclNoDefaultExpr origin clas meth_ids defm_ids inst_mod inst_ty' + makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty' clas inst_mod else - makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty' + makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id in processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds `thenTc` \ (insts_needed, method_mbinds) -> @@ -495,20 +494,18 @@ See the notes under default decls in TcClassDcl.lhs. \begin{code} makeInstanceDeclDefaultMethodExpr :: InstOrigin s - -> TcIdOcc s - -> [ClassOp] + -> [TcIdOcc s] -> [Id] -> TcType s + -> TcIdOcc s -> Int -> 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) -> +makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag + = newDicts origin op_theta `thenNF_Tc` \ (op_lie,op_dicts) -> -- def_op_id = /\ op_tyvars -> \ op_dicts -> -- defm_id inst_ty op_tyvars this_dict op_dicts - returnNF_Tc ( mkHsTyLam op_tyvars ( mkHsDictLam op_dicts ( @@ -517,25 +514,23 @@ makeInstanceDeclDefaultMethodExpr origin this_dict class_ops defm_ids inst_ty ta (this_dict : op_dicts) ))) where - idx = tag - 1 - class_op = class_ops !! idx - defm_id = defm_ids !! idx + idx = tag - 1 + meth_id = meth_ids !! idx + defm_id = defm_ids !! idx + (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id) makeInstanceDeclNoDefaultExpr :: InstOrigin s - -> Class -> [TcIdOcc s] -> [Id] - -> FAST_STRING -> TcType s + -> Class + -> FAST_STRING -> Int -> NF_TcM s (TcExpr s) -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) -> +makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag + = newDicts origin op_theta `thenNF_Tc` \ (op_lie, op_dicts) -> -- Produce a warning if the default instance method -- has been omitted when one exists in the class @@ -547,12 +542,12 @@ makeInstanceDeclNoDefaultExpr origin clas method_occs defm_ids inst_mod inst_ty HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) where - idx = tag - 1 - method_occ = method_occs !! idx - clas_op = (getClassOps clas) !! idx - defm_id = defm_ids !! idx + idx = tag - 1 + meth_id = meth_ids !! idx + clas_op = (getClassOps clas) !! idx + defm_id = defm_ids !! idx + (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id) - TcId method_id = method_occ Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id error_msg = "%E" -- => No explicit method for \" @@ -673,12 +668,6 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind -- Type check the method itself 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. - 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! @@ -696,12 +685,6 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind -- Typecheck the method 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. - 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 -- constraints could "really" be left to the next @@ -839,12 +822,12 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta, if null simpl_theta then ppNil else ppStr "=>", ppr PprDebug clas, - pprParendType PprDebug inst_ty], + pprParendGenType 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, - pprParendType PprDebug unspec_inst_ty]]) + pprParendGenType PprDebug unspec_inst_ty]]) else id) ( returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta @@ -962,7 +945,7 @@ nonBoxedPrimCCallErr clas inst_ty sty 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] + ppPStr clas_name, pprParendGenType sty inst_ty] patMonoBindsCtxt pbind sty diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs index a233623..05b4a03 100644 --- a/ghc/compiler/typecheck/TcKind.lhs +++ b/ghc/compiler/typecheck/TcKind.lhs @@ -11,7 +11,7 @@ module TcKind ( unifyKind, -- TcKind s -> TcKind s -> TcM s () kindToTcKind, -- Kind -> TcKind s - tcKindToKind -- TcKind s -> NF_TcM s Kind + tcDefaultKind -- TcKind s -> NF_TcM s Kind ) where import Kind @@ -77,7 +77,7 @@ I'm not convinced it would save time, and it's a little tricky to get right. unify_var uniq1 box1 kind2 = tcReadMutVar box1 `thenNF_Tc` \ maybe_kind1 -> case maybe_kind1 of - Just kind1 -> unify_kind kind1 kind1 + Just kind1 -> unify_kind kind1 kind2 Nothing -> unify_unbound_var uniq1 box1 kind2 unify_unbound_var uniq1 box1 kind2@(TcVarKind uniq2 box2) @@ -127,22 +127,27 @@ kindToTcKind UnboxedTypeKind = TcTypeKind kindToTcKind (ArrowKind k1 k2) = TcArrowKind (kindToTcKind k1) (kindToTcKind k2) -tcKindToKind :: TcKind s -> NF_TcM s Kind +-- Default all unbound kinds to TcTypeKind, and return the +-- corresponding Kind as well. +tcDefaultKind :: TcKind s -> NF_TcM s Kind -tcKindToKind TcTypeKind - = returnNF_Tc TypeKind +tcDefaultKind TcTypeKind + = returnNF_Tc BoxedTypeKind -tcKindToKind (TcArrowKind kind1 kind2) - = tcKindToKind kind1 `thenNF_Tc` \ k1 -> - tcKindToKind kind2 `thenNF_Tc` \ k2 -> +tcDefaultKind (TcArrowKind kind1 kind2) + = tcDefaultKind kind1 `thenNF_Tc` \ k1 -> + tcDefaultKind kind2 `thenNF_Tc` \ k2 -> returnNF_Tc (ArrowKind k1 k2) -- Here's where we "default" unbound kinds to BoxedTypeKind -tcKindToKind (TcVarKind uniq box) +tcDefaultKind (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 + Just kind -> tcDefaultKind kind + + Nothing -> -- Default unbound variables to kind Type + tcWriteMutVar box (Just TcTypeKind) `thenNF_Tc_` + returnNF_Tc BoxedTypeKind zonkTcKind :: TcKind s -> NF_TcM s (TcKind s) -- Removes variables that have now been bound. @@ -200,6 +205,6 @@ 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 "'"] + ppBesides [ppStr "`", ppr sty kind2, ppStr "'"] ]) \end{code} diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 31a3150..d5bae68 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -210,7 +210,7 @@ matchCtxt MCase match sty 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]) + 4 (ppBesides [ppr sty fun, ppSP, pprMatch sty False{-not case-} match]) \end{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 4daf3b4..de24068 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -61,7 +61,8 @@ tycon_specs = emptyFM \begin{code} tcModule :: GlobalNameMappers -- final renamer info for derivings -> RenamedHsModule -- input - -> TcM s ((TypecheckedHsBinds, -- binds from class decls; does NOT + -> TcM s ((TypecheckedHsBinds, -- record selector binds + TypecheckedHsBinds, -- binds from class decls; does NOT -- include default-methods bindings TypecheckedHsBinds, -- binds from instance decls; INCLUDES -- class default-methods binds @@ -94,17 +95,17 @@ tcModule renamer_name_funs -- pragmas, which is done lazily [ie failure just drops the pragma -- without having any global-failure effect]. - fixTc (\ ~(_, _, _, _, _, sig_ids) -> + 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, _, _, _, _) -> + 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 -> + `thenTc` \ (env, record_binds) -> -- Typecheck the instance decls, includes deriving tcSetEnv env ( @@ -115,9 +116,9 @@ tcModule renamer_name_funs buildInstanceEnvs inst_info `thenTc` \ inst_mapper -> - returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv) + returnTc (inst_mapper, env, record_binds, inst_info, deriv_binds, ddump_deriv) - ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) -> + ) `thenTc` \ (_, env, record_binds, inst_info, deriv_binds, ddump_deriv) -> tcSetEnv env ( -- Default declarations @@ -132,9 +133,9 @@ tcModule renamer_name_funs -- we silently discard the pragma tcInterfaceSigs sigs `thenTc` \ sig_ids -> - returnTc (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, sig_ids) + returnTc (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids) - )))) `thenTc` \ (env, inst_info, deriv_binds, ddump_deriv, defaulting_tys, _) -> + )))) `thenTc` \ (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, _) -> tcSetEnv env ( -- to the end... tcSetDefaultTys defaulting_tys ( -- ditto @@ -181,6 +182,7 @@ tcModule renamer_name_funs -- simplification step may have instantiated some -- ambiguous types. So, sadly, we need to back-substitute -- over the whole bunch of bindings. + zonkBinds record_binds `thenNF_Tc` \ record_binds' -> zonkBinds val_binds `thenNF_Tc` \ val_binds' -> zonkBinds inst_binds `thenNF_Tc` \ inst_binds' -> zonkBinds cls_binds `thenNF_Tc` \ cls_binds' -> @@ -189,7 +191,7 @@ tcModule renamer_name_funs -- FINISHED AT LAST returnTc ( - (cls_binds', inst_binds', val_binds', const_insts'), + (record_binds', cls_binds', inst_binds', val_binds', const_insts'), -- the next collection is just for mkInterface (fixities, exported_ids', tycons, classes, inst_info), diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 59b9967..2ea7586 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -26,6 +26,9 @@ module TcMonad( rn4MtoTcM, + TcError(..), TcWarning(..), Message(..), + mkTcErr, arityErr, + -- For closure MutableVar(..), _MutableArray ) where @@ -36,8 +39,6 @@ import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an in import Type ( Type(..), GenType ) import TyVar ( TyVar(..), GenTyVar ) import Usage ( Usage(..), GenUsage ) -import ErrUtils ( Error(..), Message(..), ErrCtxt(..), - TcWarning(..), TcError(..), mkTcErr ) import SST import RnMonad4 @@ -46,9 +47,8 @@ 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 ErrUtils ( Error(..) ) import Maybes ( MaybeErr(..) ) import Name ( Name ) import ProtoName ( ProtoName ) @@ -57,6 +57,8 @@ import UniqFM ( UniqFM, emptyUFM ) import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply ) import Unique ( Unique ) import Util +import Pretty +import PprStyle ( PprStyle(..) ) infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` \end{code} @@ -226,8 +228,8 @@ Error handling \begin{code} 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 -> + = readMutVarSST errs_var `thenSST` \ (warns,errs) -> + listNF_Tc ctxt down env `thenSST` \ ctxt_msgs -> let err = mkTcErr loc ctxt_msgs err_msg in @@ -442,3 +444,37 @@ rn4MtoTcM name_funs rn_action down env where u_var = getUniqSupplyVar down \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]) + + +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} + + diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 91b1677..1825cdf 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -24,9 +24,8 @@ import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind, mkTcArrowKind, unifyKind, newKindVar, kindToTcKind ) -import ErrUtils ( arityErr ) import Type ( GenType, Type(..), ThetaType(..), - mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, + mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy, mkSigmaTy ) import TyVar ( GenTyVar, TyVar(..), mkTyVar ) @@ -79,26 +78,18 @@ tcMonoTypeKind (MonoFunTy ty1 ty2) 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, maybe_arity, 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. - (case maybe_arity of - Just arity | arity /= n_args -> failTc (err arity) - other -> returnTc () - ) `thenTc_` - - returnTc (result_kind, foldl mkAppTy fun_ty arg_tys) - where - err arity = arityErr "Type synonym constructor" name arity n_args - n_args = length tys +tcMonoTypeKind (MonoTyApp name@(Short _ _) tys) + = -- Must be a type variable + tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> + tcMonoTyApp kind (mkTyVarTy tyvar) tys +tcMonoTypeKind (MonoTyApp name tys) + | isTyConName name -- Must be a type constructor + = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) -> + case maybe_arity of + Just arity -> tcSynApp name kind arity tycon tys -- synonum + Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data + -- for unfoldings only: tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty) = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars -> @@ -116,19 +107,28 @@ tcMonoTypeKind (MonoDictTy class_name ty) tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) -> unifyKind class_kind arg_kind `thenTc_` returnTc (mkTcTypeKind, mkDictTy clas arg_ty) +\end{code} +Help functions for type applications +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} +tcMonoTyApp fun_kind fun_ty tys + = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) -> + newKindVar `thenNF_Tc` \ result_kind -> + unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_` + returnTc (result_kind, foldl mkAppTy fun_ty arg_tys) -tc_mono_name :: Name -> NF_TcM s (TcKind s, Maybe Arity, Type) -tc_mono_name name@(Short _ _) -- Must be a type variable - = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) -> - returnNF_Tc (kind, Nothing, mkTyVarTy tyvar) +tcSynApp name syn_kind arity tycon tys + = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) -> + newKindVar `thenNF_Tc` \ result_kind -> + unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_` -tc_mono_name name | isTyConName name -- Must be a type constructor - = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) -> - returnNF_Tc (kind, maybe_arity, mkTyConTy tycon) - -tc_mono_name name -- Renamer should have got it right - = panic ("tc_mono_name:" ++ ppShow 1000 (ppr PprDebug name)) + -- Check that it's applied to the right number of arguments + checkTc (arity == n_args) (err arity) `thenTc_` + returnTc (result_kind, mkSynTy tycon arg_tys) + where + err arity = arityErr "Type synonym constructor" name arity n_args + n_args = length tys \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 52e9f05..dfd92d1 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -17,28 +17,33 @@ import RnHsSyn ( RenamedPat(..) ) import TcHsSyn ( TcPat(..), TcIdOcc(..) ) import TcMonad -import Inst ( Inst, OverloadedLit(..), InstOrigin(..), LIE(..), - emptyLIE, plusLIE, newMethod, newOverloadedLit ) +import Inst ( Inst, OverloadedLit(..), InstOrigin(..), + emptyLIE, plusLIE, plusLIEs, LIE(..), + newMethod, newOverloadedLit + ) import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey, - tcLookupLocalValueOK ) + tcLookupLocalValueOK, tcGlobalOcc ) 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 Maybes ( maybeToBool ) import Name ( Name ) import PprType ( GenType, GenTyVar ) import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, charTy, stringTy, mkListTy, mkTupleTy, addrTy, addrPrimTy ) import Pretty -import Type ( Type(..), GenType, splitFunTy, splitSigmaTy ) +import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys, + getFunTy_maybe, maybeAppDataTyCon, + Type(..), GenType + ) import TyVar ( GenTyVar ) import Unique ( Unique, eqClassOpKey ) - +import Util ( assertPanic, panic{-ToDo:rm-} ) \end{code} \begin{code} @@ -147,25 +152,21 @@ efficient? \begin{code} tcPat pat_in@(ConPatIn name pats) - = tcLookupGlobalValue name `thenNF_Tc` \ con_id -> - - tcPats pats `thenTc` \ (pats', lie, tys) -> + = tcPats pats `thenTc` \ (pats', lie, tys) -> tcAddErrCtxt (patCtxt pat_in) $ - matchConArgTys con_id tys `thenTc` \ data_ty -> + matchConArgTys name tys `thenTc` \ (con_id, data_ty) -> 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 -> - - tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> + = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> tcPat pat2 `thenTc` \ (pat2', lie2, ty2) -> tcAddErrCtxt (patCtxt pat_in) $ - matchConArgTys con_id [ty1,ty2] `thenTc` \ data_ty -> + matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) -> returnTc (ConOpPat pat1' con_id pat2' data_ty, lie1 `plusLIE` lie2, @@ -174,6 +175,52 @@ tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... %************************************************************************ %* * +\subsection{Records} +%* * +%************************************************************************ + +\begin{code} +tcPat pat_in@(RecPatIn name rpats) + = tcGlobalOcc name `thenNF_Tc` \ (con_id, _, con_rho) -> + let + (_, con_tau) = splitRhoTy con_rho + -- Ignore the con_theta; overloaded constructors only + -- behave differently when called, not when used for + -- matching. + (_, record_ty) = splitFunTy con_tau + in + -- Con is syntactically constrained to be a data constructor + ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) ) + + mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) -> + + returnTc (panic "tcPat:RecPatIn:avoid type errors"{-RecPat con_id record_ty rpats', + plusLIEs lies, + record_ty-}) + + where + do_bind expected_record_ty (field_label, rhs_pat, pun_flag) + = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) -> + + -- Record selectors all have type + -- forall a1..an. T a1 .. an -> tau + ASSERT( maybeToBool (getFunTy_maybe tau) ) + let + -- Selector must have type RecordType -> FieldType + Just (record_ty, field_ty) = getFunTy_maybe tau + in + tcAddErrCtxt (recordLabel field_label) ( + unifyTauTy expected_record_ty record_ty + ) `thenTc_` + tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) -> + tcAddErrCtxt (recordRhs field_label rhs_pat) ( + unifyTauTy field_ty rhs_ty + ) `thenTc_` + returnTc ((sel_id, rhs_pat', pun_flag), lie) +\end{code} + +%************************************************************************ +%* * \subsection{Non-overloaded literals} %* * %************************************************************************ @@ -266,24 +313,25 @@ tcPats (pat:pats) unifies the actual args against the expected ones. \begin{code} -matchConArgTys :: Id -> [TcType s] -> TcM s (TcType s) +matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s) -matchConArgTys con_id arg_tys - = tcInstType [] (idType con_id) `thenNF_Tc` \ con_ty -> +matchConArgTys con arg_tys + = tcGlobalOcc con `thenNF_Tc` \ (con_id, _, con_rho) -> let - no_of_args = length arg_tys - (con_tyvars, con_theta, con_tau) = splitSigmaTy con_ty - -- Ignore the sig_theta; overloaded constructors only + (con_theta, con_tau) = splitRhoTy con_rho + -- Ignore the con_theta; overloaded constructors only -- behave differently when called, not when used for -- matching. + (con_args, con_result) = splitFunTy con_tau con_arity = length con_args + no_of_args = length arg_tys in checkTc (con_arity == no_of_args) (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_` unifyTauTyLists arg_tys con_args `thenTc_` - returnTc con_result + returnTc (con_id, con_result) \end{code} @@ -293,4 +341,12 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat) + +recordLabel field_label sty + = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label]) + 4 (ppBesides [ppStr "with its immediately enclosing constructor"]) + +recordRhs field_label pat sty + = ppHang (ppStr "In the record field pattern") + 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat]) \end{code} diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs index 12b7009..59153c5 100644 --- a/ghc/compiler/typecheck/TcPragmas.lhs +++ b/ghc/compiler/typecheck/TcPragmas.lhs @@ -665,7 +665,7 @@ tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs) (length new_tyvars) maybe_tys locn) `thenB_Tc_` - checkB_Tc (not (all isUnboxedDataType (catMaybes maybe_tys))) + checkB_Tc (not (all isUnboxedType (catMaybes maybe_tys))) (badSpecialisationErr "data" "not all unboxed types" (length new_tyvars) maybe_tys locn) `thenB_Tc_` diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 205c881..b2afd9f 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -14,8 +14,9 @@ import Ubiq{-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), ClassDecl(..), MonoType(..), PolyType(..), - Sig(..), MonoBinds, Fake, InPat ) + Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr ) import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..) ) +import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) ) import TcMonad import Inst ( InstanceMapper(..) ) @@ -24,7 +25,7 @@ import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv, tcExtendGlobalValEnv, tcTyVarScope, tcGetEnv ) import TcKind ( TcKind, newKindVars ) -import TcTyDecls ( tcTyDecl ) +import TcTyDecls ( tcTyDecl, tcRecordSelectors ) import Bag import Class ( Class(..), getClassSelIds ) @@ -33,10 +34,10 @@ import Name ( Name, isTyConName ) import PprStyle import Pretty import UniqSet ( UniqSet(..), emptyUniqSet, - singletonUniqSet, unionUniqSets, + unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import SrcLoc ( SrcLoc ) -import TyCon ( TyCon, getTyConDataCons ) +import TyCon ( TyCon, tyConDataCons ) import Unique ( Unique ) import Util ( panic, pprTrace ) @@ -49,7 +50,7 @@ data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl tcTyAndClassDecls1 :: InstanceMapper -> Bag RenamedTyDecl -> Bag RenamedClassDecl - -> TcM s (TcEnv s) + -> TcM s (TcEnv s, TcHsBinds s) tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls = sortByDependency syn_decls cls_decls decls `thenTc` \ groups -> @@ -65,22 +66,24 @@ tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls tcGroups inst_mapper [] = tcGetEnv `thenNF_Tc` \ env -> - returnTc env + returnTc (env, EmptyBinds) tcGroups inst_mapper (group:groups) - = tcGroup inst_mapper group `thenTc` \ new_env -> + = tcGroup inst_mapper group `thenTc` \ (new_env, binds1) -> -- Extend the environment using the new tycons and classes tcSetEnv new_env $ -- Do the remaining groups - tcGroups inst_mapper groups + tcGroups inst_mapper groups `thenTc` \ (final_env, binds2) -> + + returnTc (final_env, binds1 `ThenBinds` binds2) \end{code} Dealing with a group ~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s) +tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s, TcHsBinds s) tcGroup inst_mapper decls = pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $ @@ -94,11 +97,6 @@ tcGroup inst_mapper decls -- extend-env things work properly. A bit UGH-ish. tcExtendTyConEnv tycon_names_w_arities tycons $ tcExtendClassEnv class_names 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 -> @@ -107,11 +105,34 @@ tcGroup inst_mapper decls foldBag combine (tcDecl inst_mapper) (returnTc (emptyBag, emptyBag)) decls - ) `thenTc` \ (tycons,classes) -> + ) `thenTc` \ (tycon_bag,class_bag) -> + let + tycons = bagToList tycon_bag + classes = bagToList class_bag + in - returnTc (bagToList tycons, bagToList classes, final_env) - ) `thenTc` \ (_, _, final_env) -> - returnTc final_env + -- SNAFFLE ENV TO RETURN + tcGetEnv `thenNF_Tc` \ final_env -> + + returnTc (tycons, classes, final_env) + ) `thenTc` \ (tycons, classes, final_env) -> + + + -- Create any necessary record selector Ids and their bindings + mapAndUnzipTc tcRecordSelectors tycons `thenTc` \ (sel_ids_s, binds) -> + + -- Extend the global value environment with + -- a) constructors + -- b) record selectors + -- c) class op selectors + + tcSetEnv final_env $ + tcExtendGlobalValEnv (concat (map tyConDataCons tycons)) $ + tcExtendGlobalValEnv (concat sel_ids_s) $ + tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $ + tcGetEnv `thenNF_Tc` \ really_final_env -> + + returnTc (really_final_env, foldr ThenBinds EmptyBinds binds) where (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls @@ -170,8 +191,14 @@ sortByDependency syn_decls cls_decls decls 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) +fmt_decl decl + = (ppr PprForUser name, getSrcLoc name) + where + name = get_name decl + get_name (TyD (TyData _ name _ _ _ _ _)) = name + get_name (TyD (TyNew _ name _ _ _ _ _)) = name + get_name (TyD (TySynonym name _ _ _)) = name + get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name \end{code} Edges in Type/Class decls @@ -230,7 +257,7 @@ get_sigs sigs get_sig (ClassOpSig _ ty _ _) = get_pty ty get_sig other = panic "TcTyClsDecls:get_sig" -set_name name = singletonUniqSet (getItsUnique name) +set_name name = unitUniqSet (getItsUnique name) set_to_bag set = listToBag (uniqSetToList set) \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 9d6c08f..8e37985 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -8,29 +8,42 @@ module TcTyDecls ( tcTyDecl, - tcConDecl + tcConDecl, + tcRecordSelectors ) where import Ubiq{-uitous-} -import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), MonoType ) +import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), + Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), + HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, PolyType, + Bind(..), MonoBinds(..), Sig, + MonoType ) import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) ) +import TcHsSyn ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam ) import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext ) -import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass ) +import TcType ( tcInstTyVars, tcInstType ) +import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, + newLocalId + ) import TcMonad import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind ) -import Id ( mkDataCon, StrictnessMark(..) ) +import Id ( mkDataCon, dataConSig, mkRecordSelectorId, + dataConFieldLabels, StrictnessMark(..) + ) +import FieldLabel import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) import SpecEnv ( SpecEnv(..), nullSpecEnv ) import Name ( getNameFullName, Name(..) ) import Pretty -import TyCon ( TyCon, ConsVisible(..), NewOrData(..), mkSynTyCon, mkDataTyCon ) -import Type ( getTypeKind ) -import TyVar ( getTyVarKind ) -import Util ( panic ) - +import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons ) +import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon, + mkForAllTys, mkFunTy ) +import TyVar ( getTyVarKind, elementOfTyVarSet ) +import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) ) +import Util ( panic, equivClasses ) \end{code} \begin{code} @@ -57,11 +70,16 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) (foldr mkTcArrowKind rhs_kind tyvar_kinds) `thenTc_` let - -- Construct the tycon + -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind, + -- because that's a TcKind and may not yet be fully unified with other kinds. + -- We could have augmented the tycon environment with a knot-tied kind, + -- but the simplest thing to do seems to be to get the Kind by (lazily) + -- looking at the tyvars and rhs_ty. result_kind, final_tycon_kind :: Kind -- NB not TcKind! result_kind = getTypeKind rhs_ty final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars + -- Construct the tycon tycon = mkSynTyCon (getItsUnique tycon_name) (getNameFullName tycon_name) final_tycon_kind @@ -99,6 +117,7 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra unifyKind tycon_kind (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds) `thenTc_` + -- Walk the condecls mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls `thenTc` \ con_ids -> @@ -114,19 +133,109 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra ctxt con_ids derived_classes - 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 +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} +Generating selector bindings for record delarations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +\begin{code} +tcRecordSelectors :: TyCon -> TcM s ([Id], TcHsBinds s) +tcRecordSelectors tycon + = mapAndUnzipTc (tcRecordSelector tycon) groups `thenTc` \ (ids, binds) -> + returnTc (ids, SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds))) + where + data_cons = tyConDataCons tycon + fields = [ (con, field) | con <- data_cons, + field <- dataConFieldLabels con + ] + + -- groups is list of fields that share a common name + groups = equivClasses cmp_name fields + cmp_name (_, field1) (_, field2) + = fieldLabelName field1 `cmp` fieldLabelName field2 +\end{code} + +We're going to build a record selector that looks like this: + + data T a b c = T1 { op :: a, ...} + | T2 { op :: a, ...} + | T3 + + sel :: forall a b c. T a b c -> a + sel = /\ a b c -> \ T1 { sel = x } -> x + T2 { sel = 2 } -> x + +Note that the selector Id itself is used as the field +label; it has to be an Id, you see! + +\begin{code} +tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields) + = panic "tcRecordSelector: don't typecheck" +{- + = let + field_ty = fieldLabelType first_field_label + field_name = fieldLabelName first_field_label + other_tys = [fieldLabelType fl | (_, fl) <- fields] + (tyvars, _, _, _) = dataConSig first_con + -- tyvars of first_con may be free in first_ty + in + + -- Check that all the fields in the group have the same type + -- This check assumes that all the constructors of a given + -- data type use the same type variables + checkTc (all (eqTy field_ty) other_tys) + (fieldTypeMisMatch field_name) `thenTc_` + + -- Create an Id for the field itself + tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) -> + tcInstType tenv field_ty `thenNF_Tc` \ field_ty' -> + let + data_ty' = applyTyCon tycon tyvar_tys + in + newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id -> + newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id -> + + -- Now build the selector + let + tycon_src_loc = getSrcLoc tycon + + selector_ty = mkForAllTys tyvars' $ + mkFunTy data_ty' $ + field_ty' + + selector_id = mkRecordSelectorId first_field_label selector_ty + + -- HsSyn is dreadfully verbose for defining the selector! + selector_rhs = mkHsTyLam tyvars' $ + HsLam $ + PatMatch (VarPat record_id) $ + GRHSMatch $ + GRHSsAndBindsOut [OtherwiseGRHS selector_body tycon_src_loc] + EmptyBinds field_ty' + + selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc + + mk_match (con_id, field_label) + = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $ + GRHSMatch $ + GRHSsAndBindsOut [OtherwiseGRHS (HsVar field_id) + (getSrcLoc (fieldLabelName field_label))] + EmptyBinds + field_ty' + in + returnTc (selector_id, VarMonoBind selector_id selector_rhs) +-} +\end{code} Constructors ~~~~~~~~~~~~ @@ -134,65 +243,88 @@ Constructors tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc) + = tcDataCon tycon tyvars ctxt name btys src_loc + +tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc) + = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc + +tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc) = tcAddSrcLoc src_loc $ - let - (stricts, tys) = sep_bangs btys - in - mapTc tcMonoType tys `thenTc` \ arg_tys -> + tcMonoType ty `thenTc` \ arg_ty -> let data_con = mkDataCon (getItsUnique name) (getNameFullName name) - stricts + [NotMarkedStrict] + [{- No labelled fields -}] tyvars - [] -- ToDo: ctxt; limited to tyvars in arg_tys - arg_tys + ctxt + [arg_ty] tycon -- nullSpecEnv in returnTc data_con -tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc) +tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc) = tcAddSrcLoc src_loc $ + mapTc tcField fields `thenTc` \ field_label_infos_s -> let - (stricts, tys) = sep_bangs [bty1, bty2] - in - mapTc tcMonoType tys `thenTc` \ arg_tys -> - let - data_con = mkDataCon (getItsUnique op) - (getNameFullName op) + field_label_infos = concat field_label_infos_s + stricts = [strict | (_, _, strict) <- field_label_infos] + arg_tys = [ty | (_, ty, _) <- field_label_infos] + + field_labels = [ mkFieldLabel name ty tag + | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags + ] + + data_con = mkDataCon (getItsUnique name) + (getNameFullName name) stricts + field_labels tyvars - [] -- ToDo: ctxt + (thinContext arg_tys ctxt) arg_tys tycon -- nullSpecEnv in returnTc data_con -tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc) +tcField (field_label_names, bty) + = tcMonoType (get_ty bty) `thenTc` \ field_ty -> + returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names] + +tcDataCon tycon tyvars ctxt name btys src_loc = tcAddSrcLoc src_loc $ - tcMonoType ty `thenTc` \ arg_ty -> + let + stricts = map get_strictness btys + tys = map get_ty btys + in + mapTc tcMonoType tys `thenTc` \ arg_tys -> let data_con = mkDataCon (getItsUnique name) (getNameFullName name) - [NotMarkedStrict] + stricts + [{- No field labels -}] tyvars - [] -- ToDo: ctxt - [arg_ty] + (thinContext arg_tys ctxt) + arg_tys tycon -- nullSpecEnv in returnTc data_con -tcConDecl tycon tyvars ctxt (RecConDecl con fields src_loc) - = panic "tcConDecls:RecConDecl" - - -sep_bangs btys - = unzip (map sep_bang btys) - where - sep_bang (Banged ty) = (MarkedStrict, ty) - sep_bang (Unbanged ty) = (NotMarkedStrict, ty) +-- The context for a data constructor should be limited to +-- the type variables mentioned in the arg_tys +thinContext arg_tys ctxt + = filter in_arg_tys ctxt + where + arg_tyvars = tyVarsOfTypes arg_tys + in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars + +get_strictness (Banged ty) = MarkedStrict +get_strictness (Unbanged ty) = NotMarkedStrict + +get_ty (Banged ty) = ty +get_ty (Unbanged ty) = ty \end{code} @@ -208,4 +340,7 @@ tyDataCtxt tycon_name sty tyNewCtxt tycon_name sty = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name] + +fieldTypeMisMatch field_name sty + = ppSep [ppStr "Declared types differ for field", ppr sty field_name] \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 1008e0c..530e41a 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -18,12 +18,10 @@ module TcType ( tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s) - tcInstTyVar, -- TyVar -> NF_TcM s (TcTyVar s) + tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s) + tcInstSigTyVars, 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 @@ -51,7 +49,12 @@ import Unique ( Unique ) import UniqFM ( UniqFM ) import Name ( getNameShortName ) import Maybes ( assocMaybe ) -import Util ( panic ) +import Util ( panic, pprPanic ) + +import Outputable ( Outputable(..) ) -- Debugging messages +import PprType ( GenTyVar, GenType ) +import Pretty -- ditto +import PprStyle ( PprStyle(..) ) -- ditto \end{code} @@ -74,6 +77,12 @@ type Box s = MutableVar s (TcMaybe s) data TcMaybe s = UnBound | BoundTo (TcType s) + | DontBind -- This variant is used for tyvars + -- arising from type signatures, or + -- existentially quantified tyvars; + -- The idea is that we must not unify + -- such tyvars with anything except + -- themselves. -- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s), -- because you get a synonym loop if you do! @@ -91,23 +100,41 @@ Type instantiation ~~~~~~~~~~~~~~~~~~ \begin{code} -newTcTyVar :: Maybe ShortName -> Kind -> NF_TcM s (TcTyVar s) -newTcTyVar name kind +newTcTyVar :: Kind -> NF_TcM s (TcTyVar s) +newTcTyVar kind = tcGetUnique `thenNF_Tc` \ uniq -> tcNewMutVar UnBound `thenNF_Tc` \ box -> - returnNF_Tc (TyVar uniq kind name box) + returnNF_Tc (TyVar uniq kind Nothing box) newTyVarTy :: Kind -> NF_TcM s (TcType s) newTyVarTy kind - = newTcTyVar Nothing kind `thenNF_Tc` \ tc_tyvar -> + = newTcTyVar 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 + + +-- For signature type variables, mark them as "DontBind" +tcInstTyVars, tcInstSigTyVars + :: [GenTyVar flexi] + -> NF_TcM s ([TcTyVar s], [TcType s], [(GenTyVar flexi, TcType s)]) +tcInstTyVars tyvars = inst_tyvars UnBound tyvars +tcInstSigTyVars tyvars = inst_tyvars DontBind tyvars + + +inst_tyvars initial_cts tyvars + = mapNF_Tc (inst_tyvar initial_cts) tyvars `thenNF_Tc` \ tc_tyvars -> + let + tys = map TyVarTy tc_tyvars + in + returnNF_Tc (tc_tyvars, tys, tyvars `zip` tys) + +inst_tyvar initial_cts (TyVar _ kind name _) + = tcGetUnique `thenNF_Tc` \ uniq -> + tcNewMutVar initial_cts `thenNF_Tc` \ box -> + returnNF_Tc (TyVar uniq kind name box) \end{code} @tcInstType@ and @tcInstTcType@ both create a fresh instance of a @@ -143,13 +170,14 @@ tcInstType tenv ty_to_inst 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 _)) + do env (TyVarTy tv@(TyVar uniq kind name _)) = case assocMaybe env uniq of Just tc_ty -> returnNF_Tc tc_ty - Nothing -> panic "tcInstType" + Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug tenv, + ppr PprDebug ty_to_inst, ppr PprDebug tv]) - do env (ForAllTy (TyVar uniq kind name _) ty) - = newTcTyVar name kind `thenNF_Tc` \ tc_tyvar -> + do env (ForAllTy tyvar@(TyVar uniq kind name _) ty) + = inst_tyvar DontBind tyvar `thenNF_Tc` \ tc_tyvar -> let new_env = (uniq, TyVarTy tc_tyvar) : env in @@ -166,6 +194,8 @@ tcInstTheta tenv theta go (clas,ty) = tcInstType tenv ty `thenNF_Tc` \ tc_ty -> returnNF_Tc (clas, tc_ty) +--???tcSpecTy :: Type -> NF_TcM s ( + 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 @@ -193,15 +223,10 @@ tcInstTcType tenv ty_to_inst 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') + do env (ForAllTy (TyVar uniq kind name _) ty) = panic "tcInstTcType" -- ForAllUsage impossible + \end{code} Reading and writing TcTyVars @@ -232,20 +257,22 @@ We return Nothing iff the original box was unbound. 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') + other -> returnNF_Tc other + 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' + other -> returnNF_Tc ty + short_out other_ty = returnNF_Tc other_ty \end{code} @@ -310,8 +337,8 @@ zonk tyvar_fn (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 + other -> returnNF_Tc (TyVarTy (tyvar_fn tyvar)) zonk_tv_to_tv tyvar_fn tyvar diff --git a/ghc/compiler/typecheck/Typecheck.lhs b/ghc/compiler/typecheck/Typecheck.lhs index d1893e3..64b33b7 100644 --- a/ghc/compiler/typecheck/Typecheck.lhs +++ b/ghc/compiler/typecheck/Typecheck.lhs @@ -19,7 +19,6 @@ import HsSyn import RnHsSyn import TcHsSyn -import ErrUtils ( TcWarning(..), TcError(..) ) import Pretty import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) import Maybes ( MaybeErr(..) ) @@ -41,7 +40,8 @@ typecheckModule -> -- OUTPUTS ... MaybeErr -- SUCCESS ... - (((TypecheckedHsBinds, -- binds from class decls; does NOT + (((TypecheckedHsBinds, -- record selector definitions + TypecheckedHsBinds, -- binds from class decls; does NOT -- include default-methods bindings TypecheckedHsBinds, -- binds from instance decls; INCLUDES -- class default-methods binds diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index 74c2755..c8edce0 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -9,20 +9,21 @@ updatable substitution). \begin{code} #include "HsVersions.h" -module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) where +module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where import Ubiq -- friends: import TcMonad -import Type ( GenType(..), getTypeKind ) -import TyCon ( TyCon(..), ConsVisible, NewOrData ) -import TyVar ( GenTyVar(..), TyVar(..) ) +import Type ( GenType(..), getTypeKind, mkFunTy, getFunTy_maybe ) +import TyCon ( TyCon, mkFunTyCon ) +import TyVar ( GenTyVar(..), TyVar(..), getTyVarKind ) import TcType ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..), - tcReadTyVar, tcWriteTyVar + newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType ) -- others: -import Kind ( Kind, isSubKindOf ) +import Kind ( Kind, isSubKindOf, mkTypeKind ) +import Usage ( duffUsage ) import PprType ( GenTyVar, GenType ) -- instances import Pretty import Unique ( Unique ) -- instances @@ -44,7 +45,7 @@ Unify two @TauType@s. Dead straightforward. \begin{code} unifyTauTy :: TcTauType s -> TcTauType s -> TcM s () unifyTauTy ty1 ty2 - = tcAddErrCtxt (unifyCtxt ty1 ty2) $ + = tcAddErrCtxtM (unifyCtxt ty1 ty2) $ uTys ty1 ty1 ty2 ty2 \end{code} @@ -99,8 +100,21 @@ 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 +uTys _ (AppTy s1 t1) _ (AppTy s2 t2) + = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 + + -- Special case: converts a -> b to (->) a b +uTys _ (AppTy s1 t1) _ (FunTy fun2 arg2 _) + = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 + where + s2 = AppTy (TyConTy mkFunTyCon duffUsage) fun2 + t2 = arg2 + +uTys _ (FunTy fun1 arg1 _) _ (AppTy s2 t2) + = uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 + where + s1 = AppTy (TyConTy mkFunTyCon duffUsage) fun1 + t1 = arg1 -- Type constructors must match uTys ps_ty1 (TyConTy con1 _) ps_ty2 (TyConTy con2 _) @@ -110,16 +124,62 @@ uTys ps_ty1 (TyConTy con1 _) ps_ty2 (TyConTy con2 _) 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} +Notes on synonyms +~~~~~~~~~~~~~~~~~ +If you are tempted to make a short cut on synonyms, as in this +pseudocode... + +\begin{verbatim} +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. + unifyTauTypeLists args1 args2 + else + -- Never mind. Just expand them and try again + uTys ty1 ty2 +\end{verbatim} + +then THINK AGAIN. Here is the whole story, as detected and reported +by Chris Okasaki \tr{}: +\begin{quotation} +Here's a test program that should detect the problem: + +\begin{verbatim} + type Bogus a = Int + x = (1 :: Bogus Char) :: Bogus Bool +\end{verbatim} + +The problem with [the attempted shortcut code] is that +\begin{verbatim} + con1 == con2 +\end{verbatim} +is not a sufficient condition to be able to use the shortcut! +You also need to know that the type synonym actually USES all +its arguments. For example, consider the following type synonym +which does not use all its arguments. +\begin{verbatim} + type Bogus a = Int +\end{verbatim} + +If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool}, +the unifier would blithely try to unify \tr{Char} with \tr{Bool} and +would fail, even though the expanded forms (both \tr{Int}) should +match. + +Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would +unnecessarily bind \tr{t} to \tr{Char}. + +... You could explicitly test for the problem synonyms and mark them +somehow as needing expansion, perhaps also issuing a warning to the +user. +\end{quotation} + + %************************************************************************ %* * \subsection[Unify-uVar]{@uVar@: unifying with a type variable} @@ -145,14 +205,16 @@ 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 + other -> uUnboundVar tv1 maybe_ty1 ps_ty2 ty2 -- Expand synonyms -uUnboundVar tv1 ps_ty2 (SynTy _ _ ty2) = uUnboundVar tv1 ps_ty2 ty2 +uUnboundVar tv1 maybe_ty1 ps_ty2 (SynTy _ _ ty2) + = uUnboundVar tv1 maybe_ty1 ps_ty2 ty2 -- The both-type-variable case uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) + maybe_ty1 ps_ty2 ty2@(TyVarTy tv2@(TyVar uniq2 kind2 name2 box2)) @@ -161,24 +223,34 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) = returnTc () -- Distinct type variables + -- ASSERT maybe_ty1 /= BoundTo | 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) + case (maybe_ty1, maybe_ty2) of + (_, BoundTo ty2') -> uUnboundVar tv1 maybe_ty1 ty2' ty2' + + (DontBind,DontBind) + -> failTc (unifyDontBindErr tv1 ps_ty2) + + (UnBound, _) | kind2 `isSubKindOf` kind1 + -> tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc () + + (_, UnBound) | kind1 `isSubKindOf` kind2 + -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc () + + other -> 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 () +uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) maybe_ty1 ps_ty2 non_var_ty2 + = case maybe_ty1 of + DontBind -> failTc (unifyDontBindErr tv1 ps_ty2) + + UnBound | getTypeKind non_var_ty2 `isSubKindOf` kind1 + -> occur_check non_var_ty2 `thenTc_` + tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` + returnTc () + + other -> failTc (unifyKindErr tv1 ps_ty2) where occur_check (TyVarTy tv2@(TyVar uniq2 _ _ box2)) | uniq1 == uniq2 -- Same tyvar; fail @@ -188,7 +260,7 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) ps_ty2 non_var_ty2 = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 -> case maybe_ty2 of BoundTo ty2' -> occur_check ty2' - UnBound -> returnTc () + other -> 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 @@ -197,78 +269,79 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) ps_ty2 non_var_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... +%************************************************************************ +%* * +\subsection[Unify-fun]{@unifyFunTy@} +%* * +%************************************************************************ -\begin{verbatim} -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. - unifyTauTypeLists args1 args2 - else - -- Never mind. Just expand them and try again - uTys ty1 ty2 -\end{verbatim} +@unifyFunTy@ is used to avoid the fruitless creation of type variables. -then THINK AGAIN. Here is the whole story, as detected and reported -by Chris Okasaki \tr{}: -\begin{quotation} -Here's a test program that should detect the problem: +\begin{code} +unifyFunTy :: TcType s -- Fail if ty isn't a function type + -> TcM s (TcType s, TcType s) -- otherwise return arg and result types -\begin{verbatim} - type Bogus a = Int - x = (1 :: Bogus Char) :: Bogus Bool -\end{verbatim} +unifyFunTy ty@(TyVarTy tyvar) + = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + BoundTo ty' -> unifyFunTy ty' -The problem with [the attempted shortcut code] is that -\begin{verbatim} - con1 == con2 -\end{verbatim} -is not a sufficient condition to be able to use the shortcut! -You also need to know that the type synonym actually USES all -its arguments. For example, consider the following type synonym -which does not use all its arguments. -\begin{verbatim} - type Bogus a = Int -\end{verbatim} + UnBound -> newTyVarTy mkTypeKind `thenNF_Tc` \ arg -> + newTyVarTy mkTypeKind `thenNF_Tc` \ res -> + tcWriteTyVar tyvar (mkFunTy arg res) `thenNF_Tc_` + returnTc (arg,res) -If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool}, -the unifier would blithely try to unify \tr{Char} with \tr{Bool} and -would fail, even though the expanded forms (both \tr{Int}) should -match. + DontBind -> failTc (expectedFunErr ty) -Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would -unnecessarily bind \tr{t} to \tr{Char}. +unifyFunTy other_ty + = case getFunTy_maybe other_ty of + Just arg_and_res -> returnTc arg_and_res + Nothing -> failTc (expectedFunErr other_ty) +\end{code} -... You could explicitly test for the problem synonyms and mark them -somehow as needing expansion, perhaps also issuing a warning to the -user. -\end{quotation} +%************************************************************************ +%* * +\subsection[Unify-context]{Errors and contexts} +%* * +%************************************************************************ Errors ~~~~~~ \begin{code} -unifyCtxt ty1 ty2 sty - = ppAboves [ - ppCat [ppStr "Expected:", ppr sty ty1], - ppCat [ppStr " Actual:", ppr sty ty2] - ] +unifyCtxt ty1 ty2 + = zonkTcType ty1 `thenNF_Tc` \ ty1' -> + zonkTcType ty2 `thenNF_Tc` \ ty2' -> + returnNF_Tc (err ty1' ty2') + where + err ty1' ty2' sty = ppAboves [ + ppCat [ppStr "When matching:", ppr sty ty1'], + ppCat [ppStr " against:", ppr sty ty2'] + ] unifyMisMatch ty1 ty2 sty = ppHang (ppStr "Couldn't match the type") 4 (ppSep [ppr sty ty1, ppStr "against", ppr sty ty2]) +expectedFunErr ty sty + = ppHang (ppStr "Function type expected, but found the type") + 4 (ppr sty ty) + unifyKindErr tyvar ty sty - = ppHang (ppStr "Kind mis-match between") - 4 (ppSep [ppr sty tyvar, ppStr "and", ppr sty ty]) + = ppHang (ppStr "Compiler bug: kind mis-match between") + 4 (ppSep [ppr sty tyvar, ppLparen, ppr sty (getTyVarKind tyvar), ppRparen, + ppStr "and", + ppr sty ty, ppLparen, ppr sty (getTypeKind ty), ppRparen]) + +unifyDontBindErr tyvar ty sty + = ppHang (ppStr "Couldn't match the *signature/existential* type variable") + 4 (ppSep [ppr sty tyvar, + ppStr "with the type", + ppr sty ty]) unifyOccurCheck tyvar ty sty - = ppHang (ppStr "Occur check: cannot construct the infinite type") + = ppHang (ppStr "Cannot construct the infinite type (occur check)") 4 (ppSep [ppr sty tyvar, ppStr "=", ppr sty ty]) \end{code} diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs index 0b247e4..945c66b 100644 --- a/ghc/compiler/types/Kind.lhs +++ b/ghc/compiler/types/Kind.lhs @@ -19,6 +19,8 @@ module Kind ( import Ubiq{-uitous-} import Util ( panic ) +import Outputable ( Outputable(..) ) +import Pretty \end{code} \begin{code} @@ -48,3 +50,18 @@ argKind :: Kind -> Kind -- Get argument from arrow kind argKind (ArrowKind arg_kind _) = arg_kind argKind other_kind = panic "argKind" \end{code} + +Printing +~~~~~~~~ +\begin{code} +instance Outputable Kind where + ppr sty kind = pprKind kind + +pprKind TypeKind = ppStr "*" +pprKind BoxedTypeKind = ppStr "*b" +pprKind UnboxedTypeKind = ppStr "*u" +pprKind (ArrowKind k1 k2) = ppSep [pprKind_parend k1, ppStr "->", pprKind k2] + +pprKind_parend k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen] +pprKind_parend k = pprKind k +\end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 1c2c089..be52e99 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -7,15 +7,17 @@ #include "HsVersions.h" module PprType( - GenTyVar, pprTyVar, - TyCon, pprTyCon, - GenType, pprType, pprParendType, - pprType_Internal, + GenTyVar, pprGenTyVar, + TyCon, pprTyCon, showTyCon, + GenType, + pprGenType, pprParendGenType, + pprType, pprParendType, + pprMaybeTy, getTypeString, typeMaybeString, specMaybeTysSuffix, GenClass, - GenClassOp, pprClassOp + GenClassOp, pprGenClassOp ) where import Ubiq @@ -28,7 +30,7 @@ import NameLoop -- for paranoia checking import Type ( GenType(..), maybeAppTyCon, splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy ) import TyVar ( GenTyVar(..) ) -import TyCon ( TyCon(..), ConsVisible, NewOrData ) +import TyCon ( TyCon(..), NewOrData ) import Class ( Class(..), GenClass(..), ClassOp(..), GenClassOp(..) ) import Kind ( Kind(..) ) @@ -39,7 +41,7 @@ import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( maybeToBool ) import NameTypes ( ShortName, FullName ) import Outputable ( ifPprShowAll, isAvarop, interpp'SP ) -import PprStyle ( PprStyle(..), codeStyle ) +import PprStyle ( PprStyle(..), codeStyle, showUserishTypes ) import Pretty import TysWiredIn ( listTyCon ) import Unique ( pprUnique10, pprUnique ) @@ -50,7 +52,7 @@ import Util \begin{code} instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where - ppr sty ty = pprType sty ty + ppr sty ty = pprGenType sty ty instance Outputable TyCon where ppr sty tycon = pprTyCon sty tycon @@ -60,10 +62,17 @@ instance Outputable (GenClass tyvar uvar) where ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n instance Outputable ty => Outputable (GenClassOp ty) where - ppr sty clsop = pprClassOp sty clsop + ppr sty clsop = pprGenClassOp sty clsop instance Outputable (GenTyVar flexi) where - ppr sty tv = pprTyVar sty tv + ppr sty tv = pprGenTyVar sty tv + +-- and two SPECIALIZEd ones: +instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where + ppr sty ty = pprGenType sty ty + +instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where + ppr sty ty = pprGenTyVar sty ty \end{code} %************************************************************************ @@ -72,29 +81,25 @@ instance Outputable (GenTyVar flexi) where %* * %************************************************************************ -@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@ +@pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendGenType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendGenType@ works just by setting the initial context precedence very high. \begin{code} -pprType, pprParendType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) +pprGenType, pprParendGenType :: (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 +pprGenType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC ty +pprParendGenType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC ty + +pprType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC (ty :: Type) +pprParendType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC (ty :: Type) 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 +pprMaybeTy sty (Just ty) = pprParendGenType sty ty \end{code} \begin{code} @@ -270,17 +275,8 @@ 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@} @@ -288,7 +284,7 @@ showUserishTypes other = False %************************************************************************ \begin{code} -pprTyVar sty (TyVar uniq kind name usage) +pprGenTyVar sty (TyVar uniq kind name usage) = ppBesides [pp_name, pprUnique10 uniq] where pp_name = case name of @@ -318,7 +314,7 @@ 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) +pprTyCon sty tycon@(DataTyCon uniq kind name tyvars ctxt cons derivings nd) = case sty of PprDebug -> pp_tycon_and_uniq PprShowAll -> pp_tycon_and_uniq @@ -341,7 +337,7 @@ pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion) (ppCat [ ppStr " {-", ppInt arity, interpp'SP sty tyvars, - pprParendType sty expansion, + pprParendGenType sty expansion, ppStr "-}"])) \end{code} @@ -353,9 +349,9 @@ pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion) %************************************************************************ \begin{code} -pprClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty +pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty -pprClassOp sty op = ppr_class_op sty [] op +pprGenClassOp sty op = ppr_class_op sty [] op ppr_class_op sty tyvars (ClassOp op_name i ty) = case sty of @@ -388,7 +384,7 @@ getTypeString ty | otherwise = [mod, string] where string = _PK_ (tidy (ppShow 1000 ppr_t)) - ppr_t = pprType PprForC ty + ppr_t = pprGenType PprForC ty -- PprForC expands type synonyms as it goes (is_prelude_ty, mod) @@ -446,7 +442,7 @@ pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs 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 +pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings data_or_new) specs = ppHang (ppCat [pp_data_or_new, pprContext sty ctxt, ppr sty n, @@ -507,7 +503,7 @@ pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings una where ppr_con con = let - (_, _, con_arg_tys, _) = getDataConSig con + (_, _, con_arg_tys, _) = dataConSig con in ppCat [pprNonOp PprForUser con, -- the data con's name... ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)] @@ -523,7 +519,7 @@ pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings una 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_maybe (Just ty) = pprParendGenType sty ty pp_NONE = ppPStr SLIT("_N_") diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 79dae8e..36b70dc 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -9,9 +9,10 @@ module TyCon( TyCon(..), -- NB: some pals need to see representation - Arity(..), ConsVisible(..), NewOrData(..), + Arity(..), NewOrData(..), - isFunTyCon, isPrimTyCon, isVisibleDataTyCon, + isFunTyCon, isPrimTyCon, isBoxedTyCon, + isDataTyCon, isSynTyCon, mkDataTyCon, mkFunTyCon, @@ -21,12 +22,14 @@ module TyCon( mkSynTyCon, - getTyConKind, - getTyConUnique, - getTyConTyVars, - getTyConDataCons, - getTyConDerivings, - getSynTyConArity, + tyConKind, + tyConUnique, + tyConTyVars, + tyConDataCons, + tyConFamilySize, + tyConDerivings, + tyConArity, synTyConArity, + getSynTyConDefn, maybeTyConSingleCon, isEnumerationTyCon, @@ -39,7 +42,7 @@ import NameLoop -- for paranoia checking import TyLoop ( Type(..), GenType, Class(..), GenClass, Id(..), GenId, - mkTupleCon, getDataConSig, + mkTupleCon, dataConSig, specMaybeTysSuffix ) @@ -71,7 +74,6 @@ data TyCon [(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 @@ -106,10 +108,6 @@ data TyCon -- 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 ..." @@ -129,8 +127,17 @@ isFunTyCon _ = False isPrimTyCon (PrimTyCon _ _ _) = True isPrimTyCon _ = False -isVisibleDataTyCon (DataTyCon _ _ _ _ _ _ _ ConsVisible _) = True -isVisibleDataTyCon _ = False +-- At present there are no unboxed non-primitive types, so +-- isBoxedTyCon is just the negation of isPrimTyCon. +isBoxedTyCon = not . isPrimTyCon + +-- isDataTyCon returns False for @newtype@. +-- Not sure about this decision yet. +isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True +isDataTyCon other = False + +isSynTyCon (SynTyCon _ _ _ _ _ _) = True +isSynTyCon _ = False \end{code} \begin{code} @@ -138,20 +145,20 @@ isVisibleDataTyCon _ = False kind1 = mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind kind2 = mkBoxedTypeKind `mkArrowKind` kind1 -getTyConKind :: TyCon -> Kind -getTyConKind FunTyCon = kind2 -getTyConKind (DataTyCon _ kind _ _ _ _ _ _ _) = kind -getTyConKind (PrimTyCon _ _ kind) = kind +tyConKind :: TyCon -> Kind +tyConKind FunTyCon = kind2 +tyConKind (DataTyCon _ kind _ _ _ _ _ _) = kind +tyConKind (PrimTyCon _ _ kind) = kind -getTyConKind (SpecTyCon tc tys) - = spec (getTyConKind tc) tys +tyConKind (SpecTyCon tc tys) + = spec (tyConKind 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) +tyConKind (TupleTyCon n) = mkArrow n where mkArrow 0 = mkBoxedTypeKind @@ -161,57 +168,78 @@ getTyConKind (TupleTyCon n) \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" +tyConUnique :: TyCon -> Unique +tyConUnique FunTyCon = funTyConKey +tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq +tyConUnique (TupleTyCon a) = mkTupleTyConUnique a +tyConUnique (PrimTyCon uniq _ _) = uniq +tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq +tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon" + +tyConArity :: TyCon -> Arity +tyConArity FunTyCon = 2 +tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs +tyConArity (TupleTyCon arity) = arity +tyConArity (PrimTyCon _ _ _) = 0 -- ?? +tyConArity (SpecTyCon _ _) = 0 +tyConArity (SynTyCon _ _ _ arity _ _) = arity + +synTyConArity :: TyCon -> Maybe Arity -- Nothing <=> not a syn tycon +synTyConArity (SynTyCon _ _ _ arity _ _) = Just arity +synTyConArity _ = Nothing \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" +tyConTyVars :: TyCon -> [TyVar] +tyConTyVars FunTyCon = [alphaTyVar,betaTyVar] +tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs +tyConTyVars (TupleTyCon arity) = take arity alphaTyVars +tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs +tyConTyVars (PrimTyCon _ _ _) = panic "tyConTyVars:PrimTyCon" +tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon" \end{code} \begin{code} -getTyConDataCons :: TyCon -> [Id] -getTyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _ _) = data_cons -getTyConDataCons (TupleTyCon a) = [mkTupleCon a] +tyConDataCons :: TyCon -> [Id] +tyConFamilySize :: TyCon -> Int + +tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons +tyConDataCons (TupleTyCon a) = [mkTupleCon a] +tyConDataCons other = [] + -- You may think this last equation should fail, + -- but it's quite convenient to return no constructors for + -- a synonym; see for example the call in TcTyClsDecls. + +tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons +tyConFamilySize (TupleTyCon a) = 1 \end{code} \begin{code} -getTyConDerivings :: TyCon -> [Class] -getTyConDerivings (DataTyCon _ _ _ _ _ _ derivs _ _) = derivs +tyConDerivings :: TyCon -> [Class] +tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs +tyConDerivings other = [] \end{code} \begin{code} -getSynTyConArity :: TyCon -> Maybe Arity -getSynTyConArity (SynTyCon _ _ _ arity _ _) = Just arity -getSynTyConArity other = Nothing +getSynTyConDefn :: TyCon -> ([TyVar], Type) +getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty) \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 +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 _ _ _) +isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _) = not (null data_cons) && all is_nullary data_cons where - is_nullary con = case (getDataConSig con) of { (_,_, arg_tys, _) -> + is_nullary con = case (dataConSig con) of { (_,_, arg_tys, _) -> null arg_tys } \end{code} @@ -224,8 +252,8 @@ 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 +derivedFor clas (DataTyCon _ _ _ _ _ _ derivs _) = isIn "derivedFor" clas derivs +derivedFor clas something_weird = False \end{code} %************************************************************************ @@ -241,12 +269,12 @@ 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) + 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... @@ -256,11 +284,11 @@ instance Ord3 TyCon where where tag1 = tag_TyCon other_1 tag2 = tag_TyCon other_2 - tag_TyCon FunTyCon = ILIT(1) - tag_TyCon (DataTyCon _ _ _ _ _ _ _ _ _) = ILIT(2) - tag_TyCon (TupleTyCon _) = ILIT(3) - tag_TyCon (PrimTyCon _ _ _) = ILIT(4) - tag_TyCon (SpecTyCon _ _) = ILIT(5) + tag_TyCon 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 } @@ -305,7 +333,7 @@ instance NamedThing TyCon where Nothing -> mkBuiltinSrcLoc Just name -> getSrcLoc name - getItsUnique tycon = getTyConUnique tycon + getItsUnique tycon = tyConUnique tycon fromPreludeCore tc = case get_name tc of Nothing -> True @@ -315,10 +343,9 @@ instance NamedThing TyCon where 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 +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} - diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi index ac76205..a97c27d 100644 --- a/ghc/compiler/types/TyLoop.lhi +++ b/ghc/compiler/types/TyLoop.lhi @@ -8,7 +8,7 @@ import PreludeStdIO ( Maybe ) import Unique ( Unique ) import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon, - getDataConSig, getInstantiatedDataConSig ) + dataConSig, getInstantiatedDataConSig ) import PprType ( specMaybeTysSuffix ) import NameTypes ( FullName ) import TyCon ( TyCon ) @@ -30,7 +30,7 @@ type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique) -- Needed in TyCon mkTupleCon :: Int -> Id -getDataConSig :: Id -> ([TyVar], [(Class, Type)], [Type], TyCon) +dataConSig :: Id -> ([TyVar], [(Class, Type)], [Type], TyCon) specMaybeTysSuffix :: [Maybe Type] -> _PackedString instance Eq (GenClass a b) diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index c963c1d..f59382a 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -5,6 +5,7 @@ module TyVar ( GenTyVar(..), TyVar(..), mkTyVar, getTyVarKind, -- TyVar -> Kind + cloneTyVar, alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, @@ -15,7 +16,7 @@ module TyVar ( growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv, GenTyVarSet(..), TyVarSet(..), - emptyTyVarSet, singletonTyVarSet, unionTyVarSets, + emptyTyVarSet, unitTyVarSet, unionTyVarSets, unionManyTyVarSets, intersectTyVarSets, mkTyVarSet, tyVarSetToList, elementOfTyVarSet, minusTyVarSet, isEmptyTyVarSet @@ -67,6 +68,9 @@ mkTyVar name uniq kind = TyVar uniq getTyVarKind :: GenTyVar flexi -> Kind getTyVarKind (TyVar _ kind _ _) = kind + +cloneTyVar :: GenTyVar flexi -> Unique -> GenTyVar flexi +cloneTyVar (TyVar _ k n x) u = TyVar u k n x \end{code} @@ -112,14 +116,14 @@ intersectTyVarSets:: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi unionTyVarSets :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi unionManyTyVarSets:: [GenTyVarSet flexi] -> GenTyVarSet flexi tyVarSetToList :: GenTyVarSet flexi -> [GenTyVar flexi] -singletonTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi +unitTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi elementOfTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi -> Bool minusTyVarSet :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi isEmptyTyVarSet :: GenTyVarSet flexi -> Bool mkTyVarSet :: [GenTyVar flexi] -> GenTyVarSet flexi emptyTyVarSet = emptyUniqSet -singletonTyVarSet = singletonUniqSet +unitTyVarSet = unitUniqSet intersectTyVarSets= intersectUniqSets unionTyVarSets = unionUniqSets unionManyTyVarSets= unionManyUniqSets diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index a635130..d84a1da 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -13,7 +13,7 @@ module Type ( mkForAllUsageTy, getForAllUsageTy, applyTy, - isPrimType, + isPrimType, isUnboxedType, typePrimRep, RhoType(..), SigmaType(..), ThetaType(..), mkDictTy, @@ -26,7 +26,8 @@ module Type ( matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta, - instantiateTy,instantiateUsage, + instantiateTy, instantiateTauTy, instantiateUsage, + applyTypeEnvToTy, isTauTy, @@ -43,17 +44,18 @@ 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 TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, tyConArity, + tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) import TyVar ( getTyVarKind, GenTyVar{-instances-}, GenTyVarSet(..), emptyTyVarSet, unionTyVarSets, minusTyVarSet, - singletonTyVarSet, nullTyVarEnv, lookupTyVarEnv, + unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, addOneToTyVarEnv, TyVarEnv(..) ) import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..), nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar, eqUsage ) -- others +import PrimRep ( PrimRep(..) ) import Util ( thenCmp, zipEqual, panic, panic#, assertPanic, Ord3(..){-instances-} ) @@ -233,7 +235,9 @@ getTyCon_maybe other_ty = Nothing \begin{code} mkSynTy syn_tycon tys - = SynTy syn_tycon tys (panic "Type.mkSynTy:expansion") + = SynTy syn_tycon tys (instantiateTauTy (zipEqual tyvars tys) body) + where + (tyvars, body) = getSynTyConDefn syn_tycon \end{code} Tau stuff @@ -344,11 +348,12 @@ maybeAppDataTyCon maybeAppDataTyCon ty = case (getTyCon_maybe app_ty) of - Nothing -> Nothing - Just tycon | isFunTyCon tycon - -> Nothing - | otherwise - -> Just (tycon, arg_tys, getTyConDataCons tycon) + Just tycon | isDataTyCon tycon && + tyConArity tycon == length arg_tys + -- Must be saturated for ty to be a data type + -> Just (tycon, arg_tys, tyConDataCons tycon) + + other -> Nothing where (app_ty, arg_tys) = splitAppTy ty @@ -397,7 +402,7 @@ 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 (TyConTy tycon usage) = tyConKind tycon getTypeKind (SynTy _ _ ty) = getTypeKind ty getTypeKind (FunTy fun arg _) = mkBoxedTypeKind getTypeKind (DictTy clas arg _) = mkBoxedTypeKind @@ -412,13 +417,13 @@ Free variables of a type \begin{code} tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi -tyVarsOfType (TyVarTy tv) = singletonTyVarSet tv +tyVarsOfType (TyVarTy tv) = unitTyVarSet 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 (ForAllTy tyvar ty) = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi @@ -453,17 +458,84 @@ instantiateTy tenv ty go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty) + +-- instantiateTauTy works only (a) on types with no ForAlls, +-- and when (b) all the type variables are being instantiated +-- In return it is more polymorphic than instantiateTy + +instantiateTauTy :: Eq t => [(t, GenType t' u)] -> GenType t u -> GenType t' u +instantiateTauTy tenv ty + = go ty + where + go (TyVarTy tv) = case [ty | (tv',ty) <- tenv, tv==tv'] of + (ty:_) -> ty + [] -> panic "instantiateTauTy" + go (TyConTy tycon usage) = TyConTy tycon usage + 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 + 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 +type TypeEnv = TyVarEnv Type + +applyTypeEnvToTy :: TypeEnv -> SigmaType -> SigmaType +applyTypeEnvToTy tenv ty + = mapOverTyVars v_fn ty + where + v_fn v = case (lookupTyVarEnv tenv v) of + Just ty -> ty + Nothing -> TyVarTy v +\end{code} + +@mapOverTyVars@ is a local function which actually does the work. It +does no cloning or other checks for shadowing, so be careful when +calling this on types with Foralls in them. + +\begin{code} +mapOverTyVars :: (TyVar -> Type) -> Type -> Type + +mapOverTyVars v_fn ty + = let + mapper = mapOverTyVars v_fn + in + case ty of + TyVarTy v -> v_fn v + SynTy c as e -> SynTy c (map mapper as) (mapper e) + FunTy a r u -> FunTy (mapper a) (mapper r) u + AppTy f a -> AppTy (mapper f) (mapper a) + DictTy c t u -> DictTy c (mapper t) u + ForAllTy v t -> ForAllTy v (mapper t) + tc@(TyConTy _ _) -> tc +\end{code} + +At present there are no unboxed non-primitive types, so +isUnboxedType is the same as isPrimType. + +\begin{code} +isPrimType, isUnboxedType :: GenType tyvar uvar -> Bool + isPrimType (AppTy ty _) = isPrimType ty isPrimType (SynTy _ _ ty) = isPrimType ty isPrimType (TyConTy tycon _) = isPrimTyCon tycon isPrimType _ = False + +isUnboxedType = isPrimType +\end{code} + +This is *not* right: it is a placeholder (ToDo 96/03 WDP): +\begin{code} +typePrimRep :: GenType tyvar uvar -> PrimRep + +typePrimRep (SynTy _ _ ty) = typePrimRep ty +typePrimRep (TyConTy tc _) = if isPrimTyCon tc then panic "typePrimRep:PrimTyCon" else PtrRep +typePrimRep (AppTy ty _) = typePrimRep ty +typePrimRep _ = PtrRep -- the "default" \end{code} %************************************************************************ diff --git a/ghc/compiler/utils/BitSet.lhs b/ghc/compiler/utils/BitSet.lhs index fcd837d..e7f1ec6 100644 --- a/ghc/compiler/utils/BitSet.lhs +++ b/ghc/compiler/utils/BitSet.lhs @@ -18,7 +18,7 @@ Integer and get virtually unlimited sets. module BitSet ( BitSet, -- abstract type - mkBS, listBS, emptyBS, singletonBS, + mkBS, listBS, emptyBS, unitBS, unionBS, minusBS #if ! defined(COMPILING_GHC) , elementBS, intersectBS, isEmptyBS @@ -45,10 +45,10 @@ emptyBS :: BitSet emptyBS = MkBS (int2Word# 0#) mkBS :: [Int] -> BitSet -mkBS xs = foldr (unionBS . singletonBS) emptyBS xs +mkBS xs = foldr (unionBS . unitBS) emptyBS xs -singletonBS :: Int -> BitSet -singletonBS x = case x of +unitBS :: Int -> BitSet +unitBS x = case x of I# i# -> MkBS ((int2Word# 1#) `shiftL#` i#) unionBS :: BitSet -> BitSet -> BitSet @@ -60,8 +60,8 @@ minusBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` (not# y#)) #if ! defined(COMPILING_GHC) -- not used in GHC isEmptyBS :: BitSet -> Bool -isEmptyBS (MkBS s#) = - case word2Int# s# of +isEmptyBS (MkBS s#) + = case word2Int# s# of 0# -> True _ -> False @@ -95,10 +95,10 @@ emptyBS :: BitSet emptyBS = MkBS 0 mkBS :: [Int] -> BitSet -mkBS xs = foldr (unionBS . singletonBS) emptyBS xs +mkBS xs = foldr (unionBS . unitBS) emptyBS xs -singletonBS :: Int -> BitSet -singletonBS x = MkBS (1 `ashInt` x) +unitBS :: Int -> BitSet +unitBS x = MkBS (1 `ashInt` x) unionBS :: BitSet -> BitSet -> BitSet unionBS (MkBS x) (MkBS y) = MkBS (x `logiorInt` y) @@ -106,8 +106,8 @@ unionBS (MkBS x) (MkBS y) = MkBS (x `logiorInt` y) #if ! defined(COMPILING_GHC) -- not used in GHC isEmptyBS :: BitSet -> Bool -isEmptyBS (MkBS s) = - case s of +isEmptyBS (MkBS s) + = case s of 0 -> True _ -> False @@ -115,8 +115,8 @@ intersectBS :: BitSet -> BitSet -> BitSet intersectBS (MkBS x) (MkBS y) = MkBS (x `logandInt` y) elementBS :: Int -> BitSet -> Bool -elementBS x (MkBS s) = - case logbitpInt x s of +elementBS x (MkBS s) + = case logbitpInt x s of 0 -> False _ -> True #endif @@ -144,10 +144,10 @@ emptyBS :: BitSet emptyBS = MkBS 0 mkBS :: [Int] -> BitSet -mkBS xs = foldr (unionBS . singletonBS) emptyBS xs +mkBS xs = foldr (unionBS . unitBS) emptyBS xs -singletonBS :: Int -> BitSet -singletonBS x = MkBS (1 `bitLsh` x) +unitBS :: Int -> BitSet +unitBS x = MkBS (1 `bitLsh` x) unionBS :: BitSet -> BitSet -> BitSet unionBS (MkBS x) (MkBS y) = MkBS (x `bitOr` y) @@ -155,8 +155,8 @@ unionBS (MkBS x) (MkBS y) = MkBS (x `bitOr` y) #if ! defined(COMPILING_GHC) -- not used in GHC isEmptyBS :: BitSet -> Bool -isEmptyBS (MkBS s) = - case s of +isEmptyBS (MkBS s) + = case s of 0 -> True _ -> False @@ -164,8 +164,8 @@ intersectBS :: BitSet -> BitSet -> BitSet intersectBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` y) elementBS :: Int -> BitSet -> Bool -elementBS x (MkBS s) = - case (1 `bitLsh` x) `bitAnd` s of +elementBS x (MkBS s) + = case (1 `bitLsh` x) `bitAnd` s of 0 -> False _ -> True #endif diff --git a/ghc/compiler/utils/CharSeq.lhs b/ghc/compiler/utils/CharSeq.lhs index daa865a..68948f4 100644 --- a/ghc/compiler/utils/CharSeq.lhs +++ b/ghc/compiler/utils/CharSeq.lhs @@ -65,7 +65,7 @@ cCh :: Char -> CSeq cInt :: Int -> CSeq #if defined(COMPILING_GHC) -cAppendFile :: _FILE -> CSeq -> PrimIO () +cAppendFile :: _FILE -> CSeq -> IO () #endif \end{code} @@ -128,7 +128,7 @@ cLength seq = length (cShow seq) -- *not* the best way to do this! #if defined(COMPILING_GHC) cAppendFile file_star seq - = flattenIO file_star seq + = flattenIO file_star seq `seqPrimIO` return () #endif \end{code} diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index 0308820..87da3e0 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -36,7 +36,7 @@ near the end (only \tr{#ifdef COMPILING_GHC}). module FiniteMap ( FiniteMap, -- abstract type - emptyFM, singletonFM, listToFM, + emptyFM, unitFM, listToFM, addToFM, addListToFM, IF_NOT_GHC(addToFM_C COMMA) @@ -98,7 +98,7 @@ import Pretty \begin{code} -- BUILDING emptyFM :: FiniteMap key elt -singletonFM :: key -> elt -> FiniteMap key elt +unitFM :: key -> elt -> FiniteMap key elt listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt -- In the case of duplicates, the last is taken @@ -201,7 +201,7 @@ emptyFM -- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _) -singletonFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM +unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM listToFM key_elt_pairs = addListToFM emptyFM key_elt_pairs \end{code} @@ -215,7 +215,7 @@ listToFM key_elt_pairs = addListToFM emptyFM key_elt_pairs \begin{code} addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt -addToFM_C combiner EmptyFM key elt = singletonFM key elt +addToFM_C combiner EmptyFM key elt = unitFM key elt addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt #ifdef __GLASGOW_HASKELL__ = case _tagCmp new_key key of @@ -404,7 +404,7 @@ eltsFM fm = foldFM (\ key elt rest -> elt : rest) [] fm @mkBranch@ simply gets the size component right. This is the ONLY (non-trivial) place the Branch object is built, so the ASSERTion recursively checks consistency. (The trivial use of Branch is in -@singletonFM@.) +@unitFM@.) \begin{code} sIZE_RATIO :: Int diff --git a/ghc/compiler/utils/MatchEnv.lhs b/ghc/compiler/utils/MatchEnv.lhs index 28b8ad2..81271a2 100644 --- a/ghc/compiler/utils/MatchEnv.lhs +++ b/ghc/compiler/utils/MatchEnv.lhs @@ -9,7 +9,7 @@ module MatchEnv ( MatchEnv, nullMEnv, mkMEnv, - lookupMEnv, insertMEnv, + isEmptyMEnv, lookupMEnv, insertMEnv, mEnvToList ) where @@ -36,11 +36,15 @@ match will be the most specific. nullMEnv :: MatchEnv a b nullMEnv = EmptyME +isEmptyMEnv EmptyME = True +isEmptyMEnv _ = False + mkMEnv :: [(key, value)] -> MatchEnv key value +mkMEnv [] = EmptyME mkMEnv stuff = ME stuff mEnvToList :: MatchEnv key value -> [(key, value)] -mEnvToList EmptyME = [] +mEnvToList EmptyME = [] mEnvToList (ME stuff) = stuff \end{code} diff --git a/ghc/compiler/utils/PprStyle.lhs b/ghc/compiler/utils/PprStyle.lhs index 5c3e339..b8ee2ed 100644 --- a/ghc/compiler/utils/PprStyle.lhs +++ b/ghc/compiler/utils/PprStyle.lhs @@ -8,7 +8,8 @@ module PprStyle ( PprStyle(..), - codeStyle + codeStyle, + showUserishTypes ) where CHK_Ubiq() -- debugging consistency check @@ -47,3 +48,10 @@ codeStyle (PprForAsm _ _) = True codeStyle _ = False \end{code} +\begin{code} +-- 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} diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 5875f03..31bad81 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -94,7 +94,7 @@ ppNest :: Int -> Pretty -> Pretty ppShow :: Int -> Pretty -> [Char] #if defined(COMPILING_GHC) -ppAppendFile :: _FILE -> Int -> Pretty -> PrimIO () +ppAppendFile :: _FILE -> Int -> Pretty -> IO () #endif \end{code} diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi index b5783ee..a416851 100644 --- a/ghc/compiler/utils/Ubiq.lhi +++ b/ghc/compiler/utils/Ubiq.lhi @@ -7,14 +7,20 @@ import PreludePS(_PackedString) import Bag ( Bag ) import BinderInfo ( BinderInfo ) +import CgBindery ( CgIdInfo ) +import CharSeq ( CSeq ) +import CLabel ( CLabel ) import Class ( GenClass, GenClassOp, Class(..), ClassOp ) +import ClosureInfo ( ClosureInfo, LambdaFormInfo ) import CmdLineOpts ( SimplifierSwitch, SwitchResult ) import CoreSyn ( GenCoreArg, GenCoreBinder, GenCoreBinding, GenCoreExpr, GenCoreCaseAlts, GenCoreCaseDefault ) import CoreUnfold ( UnfoldingDetails, UnfoldingGuidance ) import CostCentre ( CostCentre ) +import FieldLabel ( FieldLabel ) import FiniteMap ( FiniteMap ) +import HeapOffs ( HeapOffset ) import HsCore ( UnfoldingCoreExpr ) import HsPat ( OutPat ) import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, @@ -35,6 +41,7 @@ import Pretty ( PrettyRep ) import PrimOp ( PrimOp ) import PrimRep ( PrimRep ) import ProtoName ( ProtoName ) +import SMRep ( SMRep ) import SrcLoc ( SrcLoc ) import TcType ( TcMaybe ) import TyCon ( TyCon, Arity(..) ) @@ -75,13 +82,18 @@ class Outputable a where data ArityInfo data Bag a data BinderInfo +data CgIdInfo +data CLabel data ClassOpPragmas a data ClassPragmas a +data ClosureInfo data CostCentre +data CSeq data DataPragmas a data DeforestInfo data Demand data ExportFlag +data FieldLabel data FiniteMap a b data FullName -- NB: fails the optimisation criterion data GenClass a b @@ -97,9 +109,11 @@ data GenPragmas a data GenTyVar a -- NB: fails the optimisation criterion data GenType a b data GenUsage a +data HeapOffset data IdInfo data InstancePragmas a data Kind +data LambdaFormInfo data Literal data MaybeErr a b data MatchEnv a b @@ -113,6 +127,7 @@ data PrimRep -- NB: an enumeration data ProtoName data ShortName -- NB: fails the optimisation criterion data SimplifierSwitch +data SMRep data SrcLoc data StrictnessInfo data StrictnessMark diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index b9fc0dd..73b325c 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -23,8 +23,8 @@ module UniqFM ( UniqFM, -- abstract type emptyUFM, - singletonUFM, - singletonDirectlyUFM, + unitUFM, + unitDirectlyUFM, listToUFM, listToUFM_Directly, addToUFM, @@ -82,8 +82,8 @@ We use @FiniteMaps@, with a (@getItsUnique@-able) @Unique@ as ``key''. \begin{code} emptyUFM :: UniqFM elt isNullUFM :: UniqFM elt -> Bool -singletonUFM :: NamedThing key => key -> elt -> UniqFM elt -singletonDirectlyUFM -- got the Unique already +unitUFM :: NamedThing key => key -> elt -> UniqFM elt +unitDirectlyUFM -- got the Unique already :: Unique -> elt -> UniqFM elt listToUFM :: NamedThing key => [(key,elt)] -> UniqFM elt listToUFM_Directly @@ -149,7 +149,7 @@ type RegFinMap elt = UniqFM elt -- I don't think HBC was too happy about this (WDP 94/10) {-# SPECIALIZE - singletonUFM :: Id -> elt -> IdFinMap elt, + unitUFM :: Id -> elt -> IdFinMap elt, TyVar -> elt -> TyVarFinMap elt, Name -> elt -> NameFinMap elt IF_NCG(COMMA Reg -> elt -> RegFinMap elt) @@ -285,8 +285,8 @@ First the ways of building a UniqFM. \begin{code} emptyUFM = EmptyUFM -singletonUFM key elt = mkLeafUFM (u2i (getItsUnique key)) elt -singletonDirectlyUFM key elt = mkLeafUFM (u2i key) elt +unitUFM key elt = mkLeafUFM (u2i (getItsUnique key)) elt +unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt listToUFM key_elt_pairs = addListToUFM_C use_snd EmptyUFM key_elt_pairs diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs index 6882e68..eb9511c 100644 --- a/ghc/compiler/utils/UniqSet.lhs +++ b/ghc/compiler/utils/UniqSet.lhs @@ -13,7 +13,8 @@ Basically, the things need to be in class @NamedThing@. module UniqSet ( UniqSet(..), -- abstract type: NOT - mkUniqSet, uniqSetToList, emptyUniqSet, singletonUniqSet, + mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet, + addOneToUniqSet, unionUniqSets, unionManyUniqSets, minusUniqSet, elementOfUniqSet, mapUniqSet, intersectUniqSets, isEmptyUniqSet @@ -55,8 +56,8 @@ type UniqSet a = UniqFM a emptyUniqSet :: UniqSet a emptyUniqSet = MkUniqSet emptyUFM -singletonUniqSet :: NamedThing a => a -> UniqSet a -singletonUniqSet x = MkUniqSet (singletonUFM x x) +unitUniqSet :: NamedThing a => a -> UniqSet a +unitUniqSet x = MkUniqSet (unitUFM x x) uniqSetToList :: UniqSet a -> [a] uniqSetToList (MkUniqSet set) = eltsUFM set @@ -64,6 +65,9 @@ uniqSetToList (MkUniqSet set) = eltsUFM set mkUniqSet :: NamedThing a => [a] -> UniqSet a mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs]) +addOneToUniqSet :: NamedThing a => UniqSet a -> a -> UniqSet a +addOneToUniqSet set x = set `unionUniqSets` unitUniqSet x + unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a unionUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (plusUFM set1 set2) @@ -114,7 +118,7 @@ mapUniqSet f (MkUniqSet set) #if 0 #if __GLASGOW_HASKELL__ {-# SPECIALIZE - singletonUniqSet :: GenId ty -> GenIdSet ty, + unitUniqSet :: GenId ty -> GenIdSet ty, GenTyVar flexi -> GenTyVarSet flexi, Name -> NameSet IF_NCG(COMMA Reg -> RegSet) diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs index 6b27379..822a7a9 100644 --- a/ghc/compiler/utils/Unpretty.lhs +++ b/ghc/compiler/utils/Unpretty.lhs @@ -13,6 +13,7 @@ module Unpretty ( uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, uppSemi, uppComma, uppEquals, + uppBracket, uppParens, uppCat, uppBeside, uppBesides, uppAbove, uppAboves, uppNest, uppSep, uppInterleave, uppIntersperse, uppShow, @@ -50,6 +51,9 @@ uppChar :: Char -> Unpretty uppInt :: Int -> Unpretty uppInteger :: Integer -> Unpretty +uppBracket :: Unpretty -> Unpretty -- put brackets around it +uppParens :: Unpretty -> Unpretty -- put parens around it + uppBeside :: Unpretty -> Unpretty -> Unpretty uppBesides :: [Unpretty] -> Unpretty ppBesideSP :: Unpretty -> Unpretty -> Unpretty @@ -65,7 +69,7 @@ uppNest :: Int -> Unpretty -> Unpretty uppShow :: Int -> Unpretty -> [Char] -uppAppendFile :: _FILE -> Int -> Unpretty -> PrimIO () +uppAppendFile :: _FILE -> Int -> Unpretty -> IO () \end{code} %************************************************ @@ -96,6 +100,9 @@ uppSemi = cCh ';' uppComma = cCh ',' uppEquals = cCh '=' +uppBracket p = uppBeside uppLbrack (uppBeside p uppRbrack) +uppParens p = uppBeside uppLparen (uppBeside p uppRparen) + uppInterleave sep ps = uppSep (pi ps) where pi [] = [] diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index e59113e..68fdb49 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -77,7 +77,7 @@ module Util ( -- error handling #if defined(COMPILING_GHC) - , panic, panic#, pprPanic, pprPanic#, pprTrace + , panic, panic#, pprPanic, pprPanic#, pprError, pprTrace # ifdef DEBUG , assertPanic # endif @@ -807,6 +807,7 @@ panic x = error ("panic! (the `impossible' happened):\n\t" ++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" ) pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg)) +pprError heading pretty_msg = error (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 -- 1.7.10.4